trim a string / file path in vba? - string

Question

I have the following code which produces a list of excel file paths and email addresses contained in those workbooks.
Code:
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
This produces a result like so:
G:\folder1\file.xls email#email.com
How can i trim my file path to produce just the following:
file.xls email#email.com
I have tried
replace(pathsEmails(fle.path), "G:\folder1\" , "")
But this doesn't work. Please can someone show me where i am going wrong?
Edit:
Sometimes i have more than one email address in the cell C15.
email#email.com / tom#email.com
So this causes the emails in the workbook to be listed like so:
email#email.com / tom#email.com
Is there anyway i can replace the / and replace it with a , (to make it email friendly)

Answer 1

Using files' names as keys, you should have the desired output :
(if not, try : 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

Why not use something like mid(fle.path,11,len(fle.path) - 11)?