Question

用EXCEL,在指定文件夹查找与单元格内容相同的文件名的文件，并剪切到另一文件夹

比如某EXCEL表的A列有很多文件名，文件夹“E:\TS”中有很多个子文件夹，子文件夹里面有很多文件如何在这些文件中找出全部与A列单元格内容相同名字的文件，并复制到“E:\TS-TODAY”这个文件夹中？

Answer 1

Sub test()
    Dim FileN(), k%
    cPath = "C:\TS\"
    myFile = Dir(cPath, vbDirectory)
    k = -1
    Do While myFile <> ""
        If InStr(myFile, ".") = 0 Then
            k = k + 1
            ReDim Preserve FileN(k)
            FileN(k) = myFile
        End If
        myFile = Dir
    Loop
    If k < 0 Then Exit Sub
    For i = 1 To [a65536].End(xlUp).Row
        If Cells(i, 1) <> "" Then
            For j = 0 To k
                cFile = cPath & FileN(j) & "\" & Cells(i, 1)
                If Dir(cFile) <> "" Then
                    FileCopy cFile, "C:\TS-TODAY\" & Dir(cFile)
                    Exit For
                End If
            Next
        End If
    Next
End Sub

 上述代码必须确保A列所列文件名已经包含了扩展名，如果没有扩展名，则要不修改A列内容，要不就修改19行语句。如果扩展名都一样，则在19行的Cells(i,1)修改为Cells(i,1) & ".xls"；如果扩展名不一样，则修改为Cells(i,1) & ".*"

追问

代码路径已改为E盘的

A列是有扩展名的。.jpg

运行了没反应哦，是不是因为TS里是有很多子文件夹的原因？要找的文件在不同子文件夹中

追答

代码没什么问题，只是没有想到你的文件夹名中带有小数点(.)，略作修改即可：

Sub test()
    Dim FileN(), k%
    cPath = "C:\TS\"'修改为实际路径 
    myFile = Dir(cPath, vbDirectory)
    k = -1
    Do While myFile <> ""
        If myFile <> "." And myFile <> ".." Then
           k = k + 1
            ReDim Preserve FileN(k)
            FileN(k) = myFile
        End If
        myFile = Dir
    Loop
    If k < 0 Then Exit Sub
    For i = 1 To [a65536].End(xlUp).Row
        If Cells(i, 1) <> "" Then
            For j = 0 To k
                cFile = cPath & FileN(j) & "\" & Cells(i, 1)
                If Dir(cFile) <> "" Then
                    FileCopy cFile, "C:\TS-TODAY\" & Dir(cFile)
'修改为实际路径
                     Exit For
                End If
            Next
        End If
    Next
End Sub

追问

出现运行时错误52