excel - フォルダーを検索し、特定のキーワードと最新バージョンを含むファイルを返す

Question

指定したキーワードを含むファイルのフォルダーを検索し、ファイル名、最終更新日、および Excel ワークシートへのパスを返します。

例えば

REF     FolderPath      REF   FileName   LastModified   FilePath  
Apple   C:\Fruits           
Kale    C:\Vegetables           
Spinach C:\Vegetables           

列 A と列 B にキーワードとフォルダー パスを入力します。「Fruits」というフォルダーには、「Apple_v5.xls」という名前のファイルが含まれています。キーワード「Apple」を検索し、名前、最新バージョン、およびファイル パス (列 D、E、F) を同じスプレッドシートに返します。列 C は、列 A に再びキーワードをリストします。マクロも、最後に到達するまでキーワードのリストを下に移動し続けます。

これは私がこれまでに持っているものです。

Private Sub CommandButton1_Click()

    Dim sh As Worksheet, rng As Range, lr As Long, fPath As String
    Set sh = Sheets("Sheet2")
    lstRw = sh.Cells.Find(What:="*", After:=sh.Range("A1"), LookAt:=xlPart, LookIn:=xlFormulas, SearchOrder:=xlByRows, SearchDirection:=xlPrevious,                 MatchCase:=False).Row
    Set rng = sh.Range("A2:A" & lstRw)

    For i = 1 To 100

        fPath = Sheets("Sheet2").Range("B" & i).Value

        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("C" & x) = fWb
                    Set fs = CreateObject("Scripting.FileSystemObject")
                    Set f = fs.GetFile(fWb)
                    Worksheets("Sheet2").Range("E" & x) = f.DateLastModified
                    Worksheets("Sheet2").Range("F" & x) = f.Path
                    Worksheets("sheet2").Range("D" & x) = c.Value
                    Worksheets("sheet2").Hyperlinks.Add Anchor:=Worksheets("sheet2").Cells(x, 2), Address:=f.Path
                    Columns("A:D").AutoFit
                    Set fs = Nothing
                    Set f = Nothing
                    x = x + 1
                End If
            Next
            fWb = Dir
        Loop
        Set sh = Nothing
        Set rng = Nothing

    Next i

    Sheets("Sheet2").Activate

End Sub