CODEWITHSUNDEEP
excelvba
user2877688
user2877688

Reputation: 1

Excel VBA Filename Search Return Path

I am looking for help with VBA to find file names listed in an excel Column A from a folder and return the file path in Column B

The code below works, however if I would like excel to skip the row if the filename cannot be found so that the filepath results are returned in the cell directly next to the filename.

Private Sub CommandButton1_Click()
        Dim sh As Worksheet, rng As Range, lr As Long, fPath As String
        Set sh = Sheets(1) 'Change to actual
       lstRw = sh.Cells.Find(What:="*", After:=sh.Range("A1"), LookAt:=xlWhole, LookIn:=xlFormulas, SearchOrder:=xlByRows, SearchDirection:=xlPrevious, MatchCase:=False).Row
        Set rng = sh.Range("A2:A" & lstRw)
        With Application.FileDialog(msoFileDialogFolderPicker)
            .Show
            fPath = .SelectedItems(1)
        End With
        If Right(fPath, 1) <> "\" Then
            fPath = fPath & "\"
        End If
        fwb = Dir(fPath & "*.*")
        x = 2
        Do While fwb <> ""
            For Each c In rng
                If InStr(LCase(fwb), LCase(c.Value)) > 0 Then
                    Worksheets("Sheet2").Range("A" & x) = fwb
                    Set fs = CreateObject("Scripting.FileSystemObject")

                    Set f = fs.GetFile(fPath & fwb)
                    Worksheets("Sheet1").Range("B" & x) = f.Path


                    Set fs = Nothing
                    Set f = Nothing
                    x = x + 1


                End If
            Next
            fwb = Dir
        Loop
        Set sh = Nothing
        Set rng = Nothing
        Sheets(2).Activate

End Sub

Upvotes: 0

Views: 3145

Answers (1)

Siddharth Rout
Siddharth Rout

Reputation: 149277

As mentioned in my comments above, use the DIR inside the range loop. See this example.

Here it won't output anything to Col B if the respective cell in Col A doesn't return anything.

Sub Sample()
    Dim sh As Worksheet
    Dim rng As Range
    Dim i As Long, Lrow As Long
    Dim fPath As String, sPath As String

    With Application.FileDialog(msoFileDialogFolderPicker)
        .Show
        fPath = .SelectedItems(1)
    End With

    If Right(fPath, 1) <> "\" Then
        fPath = fPath & "\"
    End If

    Set sh = ThisWorkbook.Sheets("Sheet1")

    With sh
        Lrow = .Range("A" & .Rows.Count).End(xlUp).Row

        For i = 2 To Lrow
            '~~> Check for partial match
            sPath = fPath & "*" & .Range("A" & i).Value & "*.*"

            If Len(Trim(Dir(sPath))) > 0 Then
                .Range("B" & i).Value = Dir(sPath)
            End If
        Next i
    End With
End Sub

Note: If you do not want a partial match then consider revising

sPath = fPath & "*" & .Range("A" & i).Value & "*.*"

to

sPath = fPath & .Range("A" & i).Value & ".*"

Upvotes: 1

Related Questions