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

: 키로 파일의 이름을 사용