VBA 搜索字符串和子字符串

Question

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

8100
8152
8153

文件夹中有这样的文件：

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

如何在不重命名所有文件的情况下搜索这些文件？ 感谢 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

除了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

如您所见，我还稍微更改了代码的其他部分，使其更加健壮

Answer 2

您应该像这样发布其他帖子： Excel VBA function that checks if filename CONTAINS the value

1) 循环遍历目录中的所有文件
2) 使用上面链接的帖子中“Mat's Mug”提出的函数
ContainsAny(string source, string[] str_to_find, boolean caseSensitive) 测试文件名是否包含您的任何字符串。
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