Question

我想在excel中通过某列单元格的内容在指定文件夹中查找包含此内容的文件并将文件复制到另一个文件夹中

例如A2单元格内容是111910，我想在指定的文件夹中（D:\8029\)查找文件名包含111910的文件（里边的文件都是类似这样命名的：P-111910-O-0016-S），查找到后将文件名包含111910的文件复制到另一个文件夹（D:\123321\）,谢谢！（不懂VBA，要详细点了，谢谢）
您好，如果D：\8029文件夹下还有子文件夹怎么修改代码？

Answer 1

答：复制下面代码到模块，确保图中工作表为活动工作表，运行Demo程序。以下为运行结果截图：

代码：

Dim FindedNames() As String
Dim NumNames As Long
Sub Demo()
    Dim FilePath As String
    Dim FileName As String
    Dim Cell As Range
    
    FilePath = "D:\8029\"
    FileName = "*.*"
    Call ReDir(FilePath, FileName)
    If UBound(FindedNames) < LBound(FindedNames) Then
        MsgBox "文件夹内无文件"
        Exit Sub
    End If
    For Each Cell In Range("A2:A" & Cells(Rows.Count, 1).End(xlUp).Row)
        For i = 0 To UBound(FindedNames)
            If FindedNames(i) Like "*" & Cell & "*" Then
                FileCopy FilePath & "\" & FindedNames(i), "D:\123321\" & FindedNames(i)
                Cell.Offset(0, 1) = "复制成功"
            Else
                Cell.Offset(0, 1) = "没找到相关文件"
            End If
        Next
    Next
End Sub
Public Sub ReDir(ByVal CurrDir As String, ByVal FindName As String)
    Dim Dirs() As String
    Dim NumDirs As Long
    Dim TotalFiles, SingleFile
    Dim TotalFolders, SingleFolder
    Dim fso As Object
    Set fso = CreateObject("scripting.filesystemobject")
    Set TotalFiles = fso.GetFolder(CurrDir).Files
    Set TotalFolders = fso.GetFolder(CurrDir).SubFolders
    If TotalFiles.Count <> 0 Then
        For Each SingleFile In TotalFiles
            If fso.GetFile(SingleFile).Name Like FindName Then
                ReDim Preserve FindedNames(0 To NumNames) As String
                FindedNames(NumNames) = fso.GetFileName(SingleFile)
                NumNames = NumNames + 1
            End If
        Next
    End If
    If TotalFolders.Count <> 0 Then
        For Each SingleFolder In TotalFolders
            ReDim Preserve Dirs(0 To NumDirs) As String
            Dirs(NumDirs) = SingleFolder
            NumDirs = NumDirs + 1
        Next
    End If
    For i = 0 To NumDirs - 1
        Call ReDir(Dirs(i), FindName)
    Next i
End Sub

追问

您好，如果D：\8029文件夹下还有子文件夹怎么修改代码？谢谢

追答

不用修改，程序已包含该功能。

追问

不知道是不是我操作错误，我试了一下，搜索的是手机号，但是搜索完第六行，就会弹出这样一个错误“文件未找到”

追答

1、修改第18行为：
FileCopy FindedNames(i), "D:\123321\" & Split(FindedNames(i), "\")(UBound(Split(FindedNames(i), "\")))
2、修改第40行为：
FindedNames(NumNames) = SingleFile
3、删除20、21行

追问

在D:\8029\20141121\8009\下有包含手机号的文件，怎么是没有找到相关文件呢？

追答

我刚试了，可以复制。你没按我说的修改代码？我看你截图还有“没找到相关文件”字样，修改后是不会出现这字样的。

追问

是这样吧？运行完没反映，在12321文件夹下也没有看到复制的文件

追答

改得没错。确定是你说的12321文件夹？，程序里是：123321

追问

您好，是123321，我打错了

追答

我确测试过了，没问题。要不你提供下这些：
表格里一个内容、与之对应的完整文件名，123321文件夹截图。

追问

表格里包含18639300006，完整的文件名是P-092118-I-0253-18639300006-S

追答

完全按照你给的这些，重试了也成功的。
难道不是Windows系统？是Macintosh系统？

追问

我的是win10 64位的系统，安装的是office2016和这个有关系吗？

追答

我又看了一遍你改过的程序。确实你没修改对。
在那幅蓝色图，倒数第6行删掉。然后在倒数第4行上一行添加numnames=numnames+1

Answer 2

只有用宏代码才行。运行以下代码能满足要求：

如果一点不懂VBA代码，请分享文件来，我帮你做一个按钮，你只要按下按钮就行了

Sub 复制指定文件()
Dim Ar, I%, S$
Ar = Range("B2").CurrentRegion
For I = 2 To UBound(Ar)
   If Ar(I, 1) <> "" Then
      S = Dir(Ar(2, 4) & "\*-" & Ar(I, 1) & "-*")
      While S <> ""
         FileCopy Ar(2, 4) & "\" & S, Ar(3, 4) & "\" & S
         S = Dir
      Wend
   End If
Next
End Sub

Answer 3

Dim FindedNames() As String
Dim NumNames As Long
Sub Demo()
Dim FilePath As String
Dim FileName As String
Dim Cell As Range

FilePath = "D:\123\"
FileName = "*.*"
Call ReDir(FilePath, FileName)
If UBound(FindedNames) < LBound(FindedNames) Then
MsgBox "文件夹内无文件"
Exit Sub
End If
For Each Cell In Range("P2:P" & Cells(Rows.Count, 1).End(xlUp).Row)
For i = 0 To UBound(FindedNames)
If FindedNames(i) Like "*" & Cell & "*" Then
FileCopy FindedNames(i), "D:\111\" & Split(FindedNames(i), "\")(UBound(Split(FindedNames(i), "\")))
Cell.Offset(0, 1) = "复制成功"

End If
Next
Next
End Sub
Public Sub ReDir(ByVal CurrDir As String, ByVal FindName As String)
Dim Dirs() As String
Dim NumDirs As Long
Dim TotalFiles, SingleFile
Dim TotalFolders, SingleFolder
Dim fso As Object
Set fso = CreateObject("scripting.filesystemobject")
Set TotalFiles = fso.GetFolder(CurrDir).Files
Set TotalFolders = fso.GetFolder(CurrDir).SubFolders
If TotalFiles.Count <> 0 Then
For Each SingleFile In TotalFiles
If fso.GetFile(SingleFile).Name Like FindName Then
ReDim Preserve FindedNames(0 To NumNames) As String
FindedNames(NumNames) = fso.GetFileName(SingleFile)

FindedNames(NumNames) = SingleFile
'NumNames = NumNames + 1
End If
Next
End If
If TotalFolders.Count <> 0 Then
For Each SingleFolder In TotalFolders
ReDim Preserve Dirs(0 To NumDirs) As String
Dirs(NumDirs) = SingleFolder
NumDirs = NumDirs + 1
Next
End If
For i = 0 To NumDirs - 1
Call ReDir(Dirs(i), FindName)
Next i
End Sub