[已解决]用VBA将文件名含有某个特定内容的文件从一个文件夹复制到另外一个文件夹

gaiety1974

请教一下如何将文件名内有相同内容的文件从一个文件夹复制到另外一个文件夹，谢谢

最佳答案

月排行榜 / 总排行榜

hasyh2008

2022-6-6 13:14

Sub 复制文件()
  Dim path$
  Dim path1$
  Dim path2$
  Dim MyFile As Object
  Set MyFile = CreateObject("Scripting.FileSystemObject")
  path = ThisWorkbook.path
  path1 = path & "\A\灵飞经.pdf"
  path2 = path & "\B\灵飞经.pdf"
  MyFile.copyfile path1, path2
  Set MyFile = Nothing
End Sub

已测试过，可以！！

跳转到最佳答案楼层

hasyh2008

这个可以参考

gaiety1974

hasyh2008 发表于 2022-6-5 14:28
这个可以参考

这个是提取不同表格中内容进行提取汇总的，不是用于保存文件的，不过是个好东西， 谢谢啦

gaiety1974

找到这个代码，不过运行有点问题，还有2个函数不知道怎么加进去

Private Sub CommandButton1_Click()

    Dim Fso As Object
   
    Set Fso = CreateObject("Scripting.FileSystemObject")

    Dim fs, f, f1, fc
   
    On Error Resume Next
   
    Set fs = CreateObject("scripting.filesystemobject")
    Set f = fs.GetFolder("C:\FolderA")
    Set fc = f.Files
   
    If Err.Number <> 0 Then

        MsgBox "From Folder Open Error!" & vbCrLf & Err.Description & vbCrLf
        GoTo Err

    End If
   
    On Error GoTo 0


    For Each f1 In fc
        
        If (Right(f1, 3) = "xls" Or Right(f1, 4) = "xlsx") And InStr(1, f1, "OK") <= 0 Then
        
            On Error Resume Next

                Fso.CopyFile f1, SetFolderPath("C:\FolderB")) & GetFileName(f1)
            
                If Err.Number <> 0 Then

                    MsgBox "File Copy Error!" & vbCrLf & Err.Description
                    GoTo Err

                End If

            On Error GoTo 0
        
        End If
        
    Next

    MsgBox "File Copy is over."

Err:

    Set fs = Nothing
    Set f = Nothing
    Set f1 = Nothing
    Set fc = Nothing
    Set Fso = Nothing

End Sub

gaiety1974

函数1
Function GetFileName(ByVal s As String) As String
    Dim sname() As String
    sname = Split(s, "\")
    GetFileName = sname(UBound(sname))
End Function

gaiety1974

函数2
Function SetFolderPath(ByVal path As String) As String
    If Right(path, 1) <> "\" Then
        SetFolderPath = path & "\"
    Else
        SetFolderPath = path
    End If
End Function

gaiety1974

我测试了上面代码，Xls 是可以复制过去的，但是想用这个代码复制PDF文件确不行，我是直接改 这句把XLS改为PDF，If (Right(f1, 3) = "PDF" Or Right(f1, 4) = "DOCX") And InStr(1, f1, "OK") <= 0 Then，然后就是不行，请高手帮忙指点一下， 谢谢

hasyh2008

可以用Name path1 as path2 试试

gaiety1974

hasyh2008 发表于 2022-6-6 11:33
可以用Name path1 as path2 试试

不行啊哥，代码换回XLS的就可以， 就是PDF不行

gaiety1974

gaiety1974 发表于 2022-6-6 12:59
不行啊哥，代码换回XLS的就可以， 就是PDF不行

Docx Word文件也能复制过去了，就是PDF的不行，醉了