在vba中修剪string/文件path？

我有下面的代码，其中产生的Excel文件path和电子邮件地址包含在这些工作簿中的列表。

码：

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] 

我如何修剪我的文件path只产生以下内容：

 file.xls [e-mail] 

我努力了

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

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

编辑：

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

 [e-mail] / [e-mail] 

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

 [e-mail] / [e-mail] 

有反正我可以取代/和取代它, （使其电子邮件友好）

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) ？