文字列/ファイルパスをvbaでトリミングしますか？

Question

私はこれらのブックに含まれているExcelファイルパスと電子メールアドレスのリストを生成する次のコードを持っています。私は、次のちょうど生産するために私のファイルパスをトリミングすることができますどのように

G:\folder1\file.xls    email@email.com 

：：これはそうのような結果が生成さ

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 

：

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

、あなたは所望の出力が必要

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)のようなものを使用しないのはなぜですか？

（ない場合は、試してみてください：pathsEmails(Replace(fle.Path,weekFolder.Path,vbNullString)) = book.Worksheets(1).Range("C15").Value）キーとしてファイルの名前を使用して