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

发布网友发布时间：2022-04-30 04:05

共3个回答

热心网友时间：2023-10-11 05:43

答：复制下面代码到模块，确保图中工作表为活动工作表，运行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

热心网友时间：2023-10-11 05:43

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

如果一点不懂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

热心网友时间：2023-10-11 05:44

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