VBA搜索字符串，字符串

Question

我有搜索和複製文件夾中的一些文件從Excel列表，如啓動：

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

：

8100 
8152 
8153 

有命名這樣的文件的文件夾中

如何在不重命名所有文件的情況下搜索這些文件？ 由於user3598756，這是我現在使用與Excel列表相同的名稱和文件夾搜索文件的代碼：

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 

代碼工作與前綴的所有文件，但不使用的文件後綴（即：「8153（2）.pdf」）。代碼只返回一個文件，但我需要所有與單元格值匹配的文件。我需要延長我對多年組織的子文件夾的研究（即：「D：\ myfolder \ 2015」，「D：\ myfolder \ 2016」等）。

Answer 1

你應該讓這樣的其它職位： Excel VBA function that checks if filename CONTAINS the value

1）循環儘管在目錄中的所有文件
2）測試，如果文件名包含任何與功能
ContainsAny（字符串源的字符串， string [] str_to_find，boolean caseSensitive）
由上面鏈接的帖子中的「Mat's Mug」提出。
3）如果文件中包含任何你正在尋找（函數返回TRUE）的字符串，複製該文件

Public Function ContainsAny(ByVal string_source As String, ByVal caseSensitive As Boolean, ParamArray find_strings() As Variant) As Boolean 

Dim find As String, i As Integer, found As Boolean 

For i = LBound(find_strings) To UBound(find_strings) 

    find = CStr(find_strings(i)) 
    found = Contains(string_source, find, caseSensitive) 

    If found Then Exit For 
Next 

ContainsAny = found 
End Function 

Answer 2

比InStr()功能以外，你可以使用Dir()有星號（*），如以下（評論）代碼：

Option Explicit 

Sub search() 
    Dim Source As String, Dest As String, Missed As String, fileFound As String 
    Dim cell As Range 

    Source = "D:\varie\Lavoro\Programming\VBA\Forum\Stack Overflow\Test\" 
    Dest = "D:\varie\Lavoro\Programming\VBA\Forum\Stack Overflow\Test\output" 
    'Source = "D:\myfolder\" 
    'Dest = "D:\myfolder\research" 
    If Dir(Dest, vbDirectory) = "" Then MkDir Dest '<--| cerate destination folder if not alerady there 
    With Worksheets("PDF") '<-- reference your worksheet with pdf names (change "PDF" to your actual sheet name) 
     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 
      fileFound = Dir(Source & "\*" & cell.Value & "*.Pdf") '<-- look for a source folder file whose name contains the current cell value 
      If fileFound <> "" Then '<-- if found... 
       FileCopy Source & 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, Left(Missed, Len(Missed) - 2) 
     Close #FF 
    End If 

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

，你可以看到我也稍微改變你的代碼的其他一些地方，使其多了幾分穩健