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

该代码适用于所有带前缀的文件，但不包含带后缀的文件（即：＆＃34; 8153（2）.pdf＆＃34;）。代码只返回一个文件，但我需要所有匹配单元格值的文件。我需要将我的研究扩展到按年组织的子文件夹中（即：＆＃34; D：\ myfolder \ 2015＆＃34;，＆＃34; D：\ myfolder \ 2016＆＃34;等）。

Answer 1

你应该像这样的帖子： Excel VBA function that checks if filename CONTAINS the value

1）循环浏览目录中的所有文件 2）测试文件名是否包含具有函数
ContainsAny的任何字符串（字符串源，字符串[] str_to_find，布尔caseSensitive）由＆＃34; Mat＆＃39; Mug＆＃34;在上面链接的帖子中。
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

正如您所看到的，我还略微更改了代码的其他部分，以使其更加强大

VBA搜索字符串和子字符串

2 个答案: