trim a string / file path in vba?

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 protected]

How can i trim my file path to produce just the following:

file.xls                        [email protected]

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 protected] / [email protected]

So this causes the emails in the workbook to be listed like so:

[email protected] / [email protected]

Is there anyway i can replace the / and replace it with a , (to make it email friendly)

Your result seems to be outputed in 2 columns (G and V), am I right? If you don't need the full path of the files and you don't have the same names for files, you could use the filenames as keys into your dictionnary pathsEmails(fle.name) = book.Worksheets(1).Range("C15").Value. Or loop on the columns to remove everything before the "\" — R3uK
@R3uK yes column V contains the email and column G contains the workbook file path — user7415328
Ok! And do you have the same file's names sometimes? And do you need to use the full path of the files elsewhere than in the code you posted? — R3uK
@R3uK no i only use the full path in the code posted. And each file name is different — user7415328
Your edit is actually another question; and you could have figured it out quite simply, as you already know how to use the Replace function. Also, your first question isn't rocket science and you could have found the answer with a little bit of research into the File object, using the Name property instead of the Path property. — Zev Spitz

R3uK R3uK · Accepted Answer · 2017-01-25T09:06:31

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

trim a string / file path in vba?

2 Answers