修剪vba中的字符串/文件路径？

Posted 2023-04-19

【中文标题】修剪vba中的字符串/文件路径？

【英文标题】：trim a string / file path in vba?

【发布时间】：2017-01-25 08:36:35

【问题描述】：

我有以下代码生成这些工作簿中包含的 excel 文件路径和电子邮件地址列表。

代码：

Option Explicit
Sub SO()
    'clear the existing list here -- not implemented
    '...
    Range("G17:G" & ActiveSheet.Cells.SpecialCells(xlCellTypeLastCell).Row).ClearContents
    Range("V17:V" & ActiveSheet.Cells.SpecialCells(xlCellTypeLastCell).Row).ClearContents
    Range("AD17:AD" & ActiveSheet.Cells.SpecialCells(xlCellTypeLastCell).Row).ClearContents
    Dim pathsEmails As New Dictionary
    Dim app As New Excel.Application

    Dim fso As New FileSystemObject
    Dim weekFolder As Folder
    'replace 1 with either the name or the index of the worksheet which holds the week folder path
    'replace B4 with the address of the cell which holds the week folder path
    Set weekFolder = fso.GetFolder(Worksheets(1).Range("I8").Value)

    Dim supplierFolder As Folder, fle As file
    For Each supplierFolder In weekFolder.SubFolders
        For Each fle In supplierFolder.files

            'test whether this is an Excel file
            If fle.Type Like "*Excel*" Then

                'open the workbook, read and save the email, and close the workbook
                Dim book As Workbook
                On Error Resume Next
                Set book = app.Workbooks.Open(fle.path, , True)
                pathsEmails(fle.path) = book.Worksheets(1).Range("C15").Value
                book.Close False

            End If

        Next
    Next

    app.Quit


    'copy the paths and emails to the worksheet
    '(as above) replace 1 with either the name or the index of the worksheet which holds the week folder path
    'paths are pasted in starting at cell B6, downwards
    'emails are pasted in starting at cell C6, downwards
    Worksheets(1).Range("G17").Resize(UBound(pathsEmails.Keys) + 1, 1).Value = WorksheetFunction.Transpose(pathsEmails.Keys)
    Worksheets(1).Range("V17").Resize(UBound(pathsEmails.Items) + 1, 1).Value = WorksheetFunction.Transpose(pathsEmails.Items)

    'Clear empty cells
    On Error Resume Next
    Range("V17:V" & ActiveSheet.Cells.SpecialCells(xlCellTypeLastCell).Row).SpecialCells(xlBlanks).EntireRow.Delete


End Sub

这会产生如下结果：

G:\folder1\file.xls                [e-mail]

如何修剪我的文件路径以生成以下内容：

file.xls                        [e-mail]

我试过了

replace(pathsEmails(fle.path), "G:\folder1\" , "")

但这不起作用。请问有人可以告诉我哪里出错了吗？

编辑：

有时我在单元格 C15 中有多个电子邮件地址。

[e-mail] / [e-mail]

所以这会导致工作簿中的电子邮件如下所示：

[e-mail] / [e-mail]

无论如何我可以替换/ 并用, 替换它（使其对电子邮件友好）

【问题讨论】：

您的结果似乎在 2 列（G 和 V）中输出，对吗？如果您不需要文件的完整路径并且您没有相同的文件名称，您可以使用文件名作为您的字典 pathsEmails(fle.name) = book.Worksheets(1).Range("C15").Value 的键。或在列上循环以删除“\”之前的所有内容

@R3uK 是 V 列包含电子邮件，G 列包含工作簿文件路径

好的！你有时有相同的文件名吗？您是否需要在您发布的代码之外的其他地方使用文件的完整路径？

@R3uK 不，我只在发布的代码中使用完整路径。而且每个文件名都不一样

您的编辑实际上是另一个问题；你可以很简单地弄清楚，因为你已经知道如何使用Replace 函数。此外，您的第一个问题不是火箭科学，您可以通过使用 Name 属性而不是 Path 属性对 File 对象进行一些研究来找到答案。

【参考方案1】：

使用文件名作为键，你应该有想要的输出：

（如果没有，请尝试：pathsEmails(Replace(fle.Path,weekFolder.Path,vbNullString)) = book.Worksheets(1).Range("C15").Value）

Option Explicit
Sub SO()
    'clear the existing list here -- not implemented
    '...
    Dim wS As Worksheet
    Dim LastRow As Long
    Dim i as Long

    Set wS = ThisWorkbook.ActiveSheet
    With wS
        LastRow = .Range("G" & .Rows.Count).End(xlUp).Row

        .Range("G17:G" & LastRow).ClearContents
        .Range("V17:V" & LastRow).ClearContents
        .Range("AD17:AD" & LastRow).ClearContents
    End With

    Dim pathsEmails As New Dictionary
    Dim app As New Excel.Application
    Dim fso As New FileSystemObject
    Dim weekFolder As Folder
    Dim supplierFolder As Folder
    Dim fle As File
    'replace 1 with either the name or the index of the worksheet which holds the week folder path
    'replace B4 with the address of the cell which holds the week folder path
    Set weekFolder = fso.GetFolder(wS.Range("I8").Value)
    For Each supplierFolder In weekFolder.SubFolders
        For Each fle In supplierFolder.Files
            'test whether this is an Excel file
            If fle.Type Like "*Excel*" Then
                'open the workbook, read and save the email, and close the workbook
                Dim book As Workbook
                On Error Resume Next
                Set book = app.Workbooks.Open(fle.Path, , True)
                pathsEmails(fle.Name) = book.Worksheets(1).Range("C15").Value
                book.Close False
            End If
        Next fle
    Next supplierFolder
    app.Quit

    'copy the paths and emails to the worksheet
    '(as above) replace 1 with either the name or the index of the worksheet which holds the week folder path
    'paths are pasted in starting at cell B6, downwards
    'emails are pasted in starting at cell C6, downwards
    With wS
        .Range("G17").Resize(UBound(pathsEmails.Keys) + 1, 1).Value = WorksheetFunction.Transpose(pathsEmails.Keys)
        .Range("V17").Resize(UBound(pathsEmails.Items) + 1, 1).Value = WorksheetFunction.Transpose(pathsEmails.Items)
        'Clear empty cells
        On Error Resume Next
        LastRow = .Range("G" & .Rows.Count).End(xlUp).Row
        For i = 17 To LastRow
            .Range("V" & i)=Replace(.Range("V" & i),"/",",")
        Next i
        .Range("V17:V" & LastRow).SpecialCells(xlBlanks).EntireRow.Delete
    End With
End Sub

【讨论】：

谢谢，效果很好。另一件事，有时我在单元格 C15 中有不止一封电子邮件，请参阅更新的问题。

@user7415328 ：您必须循环输出邮件的范围并使用类似Cell=Replace(Cell,"/",",") ;)

谢谢我试过这个，但它似乎对我不起作用。您能否告诉我如何将其与您提供的代码结合起来？对不起，我是 vba 的新手

【参考方案2】：

为什么不使用mid(fle.path,11,len(fle.path) - 11) 之类的东西？

【讨论】：

当它在文件夹上循环时，除非碰巧它们都以相同的长度命名，否则这将不起作用..