用Excel VBA拷貝特定文件到另一文件夾的方法

  假設我們需要將文件夾“C:\FolderA”中的符合下面條件的文件，拷貝到“C:\FolderB”中。

  拷貝條件：擴展名是xls或xlsx，並且文件名中不包含“OK”字樣。

  在Excel中插入一個ActiveX按鈕，在按鈕的事件中加入如下代碼：

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

 

上面事件中用到了兩個函數，具體代碼如下：
GetFileName用來得到一個完整路徑中的文件名（帶擴展名）

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

SetFolderPath用來將不是\結尾的路徑后面加上\

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