假設我們需要將文件夾“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