Excel VBA 在文件夹和子文件夹中搜索并返回多个文件

Question

我必须从 Excel 列表开始搜索并复制文件夹中的多个文件，例如：

8100 ' cell "A2"
8152 ' cell "A3"
8153 ' cell "A4"

在源文件夹中有这样的文件：

8153.pdf
100_8152.pdf
102_8153.pdf
8153 (2).pdf

如何找到这些文件并将所有匹配的文件复制到单独的文件夹中？该代码仅返回一个文件，但我需要与单元格值匹配的所有文件。我还需要扩展我对按年组织的子文件夹的研究（即：“D:\myfolder\2015”、“D:\myfolder\2016”等）。 感谢 user3598756，我现在正在使用此代码：

Option Explicit

Sub cerca()
Dim T As Variant
Dim D As Variant

T = VBA.Format(VBA.Time, "hh.mm.ss")
D = VBA.Format(VBA.Date, "yyyy.MM.dd")

Dim Source As String
Dim Dest As String
Dim Missed As String
Dim fileFound As String
Dim CodiceCS As Variant
Dim cell As Range

Source = "D:\myfolder\"
Dest = "D:\myfolder\research " & D & " " & T

If Dir(Dest, vbDirectory) = "" Then MkDir Dest '<--| create destination folder if not alerady there

With Worksheets("Cerca") '<-- reference your worksheet with pdf names
    For Each cell In .Range("A2", .Cells(.Rows.Count, "A").End(xlUp)).SpecialCells(xlCellTypeConstants) '<-- loop through its column "A" cells with "constant" (i.e. not resulting from formulas) values from row 2 down to last non empty one
        CodiceCS = VBA.Left((cell.Value), 4)
        fileFound = Dir(Source & "\" & CodiceCS & "\*" & cell.Value & "*.Pdf") '<-- look for a source folder file whose name contains the current cell value
        If fileFound <> "" Then '<-- if found...
            FileCopy Source & "\" & CodiceCS & "\" & fileFound, Dest & "\" & fileFound '<-- ...copy to destination folder
        Else '<--otherwise...
            Missed = Missed & cell.Value & vbCrLf '<--... update missing files list
        End If
    Next cell
End With

If Missed <> "" Then '<-- if there's any missing file
    Dim FF As Long
    FF = FreeFile

    Open (Dest & "\" & "MissingFiles.txt") For Output As #FF
    Write #FF, VBA.Left(Missed, Len(Missed) - 2)
    Close #FF
End If

MsgBox "OK"
Shell "explorer.exe " + Dest, vbNormalFocus

End Sub

Answer 1

此代码会将主文件夹和子文件夹中的所有文件名放入一个数组中。然后它会在数组中查找匹配的值。

我已经添加了几行我已经注释掉的额外行 - 这些是您可以在代码中执行的不同选项。

Public Sub cerca()

    Dim DT As String
    Dim Source As String
    Dim Dest As String
    Dim vFiles As Variant
    Dim vFile As Variant
    Dim rCell As Range
    Dim oFSO As Object
    Dim FileFound As Boolean
    Dim FF As Long

    FF = FreeFile
    DT = Format(Now, "yyyy.mm.dd hh.mm.ss")
    Set oFSO = CreateObject("Scripting.FileSystemObject")
    Source = "D:\myfolder\"
    Dest = "D:\myfolder\research  " & DT

    If Dir(Dest, vbDirectory) = "" Then MkDir Dest

    'Get the full path name of all PDF files in the source folder and subfolders.
    vFiles = EnumerateFiles(Source, "pdf")

    With Worksheets("Cerca")
        'Look at each cell containing file names.
        For Each rCell In .Range("A1", .Cells(.Rows.Count, "A").End(xlUp))
            FileFound = False 'Assume the file hasn't been found.
            'Check each value in the array of files.
            For Each vFile In vFiles
                ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
                'Use this line if the file name in the sheet exactly match the file name in the array. '
                '8152 and 100_8152.pdf are not a match, 8152 and 8152.pdf are a match.                                                '
                ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
                If rCell & ".pdf" = FileNameOnly(vFile) Then

                '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
                'Use this line if the file name in the sheet should appear in the file name in the array. '
                '8152 and 100_8152.pdf are a match, 1852 and 8152.pdf are a match.                        '
                '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
                'If InStr(FileNameOnly(vFile), rCell.Value) > 0 Then

                    'If found copy the file over and indicate it was found.

                    '''''''''''''''''''''''''''''''''''''''''''''''''''''''
                    'This line will use the rcell value to name the file. '
                    '''''''''''''''''''''''''''''''''''''''''''''''''''''''
                    oFSO.CopyFile vFile, Dest & "\" & rCell & ".pdf"

                    ''''''''''''''''''''''''''''''''''''''
                    'This line will not rename the file. '
                    ''''''''''''''''''''''''''''''''''''''
                    'oFSO.CopyFile vFile, Dest & "\" & FileNameOnly(vFile)
                    FileFound = True
                End If
            Next vFile

            'Any file names that aren't found are appended to the text file.
            If Not FileFound Then
                Open (Dest & "\" & "MissingFiles.txt") For Append As #FF ' creates the file if it doesn't exist
                Print #FF, rCell ' write information at the end of the text file
                Close #FF
            End If
        Next rCell
    End With
End Sub

Public Function EnumerateFiles(sDirectory As String, _
            Optional sFileSpec As String = "*", _
            Optional InclSubFolders As Boolean = True) As Variant

    EnumerateFiles = Filter(Split(CreateObject("WScript.Shell").Exec _
        ("CMD /C DIR """ & sDirectory & "*." & sFileSpec & """ " & _
        IIf(InclSubFolders, "/S ", "") & "/B /A:-D").StdOut.ReadAll, vbCrLf), ".")

End Function

Public Function FileNameOnly(ByVal FileNameAndPath As String) As String
    FileNameOnly = Mid(FileNameAndPath, InStrRev(FileNameAndPath, "\") + 1, Len(FileNameAndPath))
End Function