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

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

1 个答案: