Question

我有以下代码，它会生成这些工作簿中包含的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                email@email.com

如何修剪文件路径以产生以下内容：

file.xls                        email@email.com

我试过了

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

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

编辑：

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

email@email.com / tom@email.com

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

email@email.com / tom@email.com

无论如何，我可以替换/并将其替换为,（以使其成为电子邮件友好型）

Answer 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

Answer 2

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

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

2 个答案: