エクセルVBAフォルダとサブフォルダ内を検索すると返され、複数のファイルを、私は検索など、Excelのリストから始まるフォルダ内のファイルの数をコピーする必要が

Question

：ような名前のファイルがあるソースフォルダ内

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

このファイル：

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

これらのファイルを見つけて、別のフォルダにあるすべてのファイルをコピーするにはどうすればよいですか？コードは1つのファイルしか返しませんが、セルの値に一致するすべてのファイルが必要です。私は年単位で整理されたサブフォルダで研究を拡張する必要があります（例： "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