我正在研究成功將檔案（基于部分名稱串列）從一個檔案夾復制到另一個檔案夾的代碼。但是，我只是想請求是否有任何可能的方法讓代碼在復制之前也可以讀取檔案的擴展名。例如，A 列包含檔案名，B 列包含每個檔案的擴展名，因此代碼應首先讀取檔案名，然后讀取擴展名，如果匹配則復制，否則跳過。我有以下擴展名的檔案。
XML PDF TXT ZIP RAR PDF
我的代碼也在下面提到
Sub moveFilesFromListPartial()
Const sPath As String = "E:\Uploading\Source"
Const dPath As String = "E:\Uploading\Destination\Destination_2\!Destination_3"
Const fRow As Long = 2
Const Col As String = "B"
' Reference the worksheet.
Dim ws As Worksheet: Set ws = Sheet2
' Calculate the last row,
' i.e. the row containing the last non-empty cell in the column.
Dim lRow As Long: lRow = ws.Cells(ws.Rows.Count, Col).End(xlUp).Row
' Validate the last row.
If lRow < fRow Then
MsgBox "No data in column range.", vbCritical
Exit Sub
End If
' Early Binding - needs a reference
' to 'Tools > References > Microsoft Scripting Runtime' (has intelli-sense)
Dim fso As Scripting.FileSystemObject
Set fso = New Scripting.FileSystemObject
' Late Binding - needs no reference (no intelli-sense)
'Dim fso As Object: Set fso = CreateObject("Scripting.FileSystemObject")
' Validate the source folder path.
Dim sFolderPath As String: sFolderPath = sPath
If Right(sFolderPath, 1) <> "\" Then sFolderPath = sFolderPath & "\"
If Not fso.FolderExists(sFolderPath) Then
MsgBox "The source folder path '" & sFolderPath _
& "' doesn't exist.", vbCritical
Exit Sub
End If
' Validate the destination folder path.
Dim dFolderPath As String: dFolderPath = dPath
If Right(dFolderPath, 1) <> "\" Then dFolderPath = dFolderPath & "\"
If Not fso.FolderExists(dFolderPath) Then
MsgBox "The destination folder path '" & dFolderPath _
& "' doesn't exist.", vbCritical
Exit Sub
End If
Dim r As Long ' current row in worksheet column
Dim sFilePath As String
Dim sPartialFileName As String
Dim sFileName As String
Dim dFilePath As String
Dim sYesCount As Long ' source file moved
Dim sNoCount As Long ' source file not found
Dim dYesCount As Long ' source file exists in destination folder
Dim BlanksCount As Long ' blank cell
For r = fRow To lRow
sPartialFileName = CStr(ws.Cells(r, Col).Value)
If Len(sPartialFileName) > 3 Then ' the cell is not blank
' 'Begins with' sPartialFileName
sFileName = Dir(sFolderPath & sPartialFileName & "*")
' or instead, 'Contains' sPartialFileName
'sFileName = Dir(sFolderPath & "*" & sPartialFileName & "*")
Do While sFileName <> ""
If Len(sFileName) > 3 Then ' source file found
sFilePath = sFolderPath & sFileName
dFilePath = dFolderPath & sFileName
If Not fso.FileExists(dFilePath) Then ' the source file...
fso.CopyFile sFilePath, dFilePath ' ... doesn't exist...
sYesCount = sYesCount 1 ' ... in the destination
Else ' the source file exists in the destination folder
dYesCount = dYesCount 1
End If
Else ' the source file doesn't exist
sNoCount = sNoCount 1
End If
sFileName = Dir
Loop
Else ' the cell is blank
BlanksCount = BlanksCount 1
End If
Next r
End Sub
我會很感激
uj5u.com熱心網友回復：
請使用下一個更新的代碼。它使用了我上述評論中的建議。僅當檔案部分名稱存在于“A:A”列中且擴展名存在于“B:B”中時，它才有效：
Sub moveFilesFromListPartial()
Const sPath As String = "E:\Uploading\Source"
Const dPath As String = "E:\Uploading\Destination\Destination_2\!Destination_3"
Const fRow As Long = 2
Const Col As String = "A", colExt As String = "B"
' Reference the worksheet.
Dim ws As Worksheet: Set ws = Sheet2
' Calculate the last row,
' i.e. the row containing the last non-empty cell in the column.
Dim lRow As Long: lRow = ws.cells(ws.rows.count, Col).End(xlUp).row
' Validate the last row.
If lRow < fRow Then
MsgBox "No data in column range.", vbCritical
Exit Sub
End If
' Early Binding - needs a reference
' to 'Tools > References > Microsoft Scripting Runtime' (has intelli-sense)
Dim fso As Scripting.FileSystemObject
Set fso = New Scripting.FileSystemObject
' Late Binding - needs no reference (no intelli-sense)
'Dim fso As Object: Set fso = CreateObject("Scripting.FileSystemObject")
' Validate the source folder path.
Dim sFolderPath As String: sFolderPath = sPath
If Right(sFolderPath, 1) <> "\" Then sFolderPath = sFolderPath & "\"
If Not fso.FolderExists(sFolderPath) Then
MsgBox "The source folder path '" & sFolderPath _
& "' doesn't exist.", vbCritical
Exit Sub
End If
' Validate the destination folder path.
Dim dFolderPath As String: dFolderPath = dPath
If Right(dFolderPath, 1) <> "\" Then dFolderPath = dFolderPath & "\"
If Not fso.FolderExists(dFolderPath) Then
MsgBox "The destination folder path '" & dFolderPath _
& "' doesn't exist.", vbCritical
Exit Sub
End If
Dim r As Long ' current row in worksheet column
Dim sFilePath As String
Dim sPartialFileName As String
Dim sFileName As String
Dim dFilePath As String
Dim sYesCount As Long ' source file moved
Dim sNoCount As Long ' source file not found
Dim dYesCount As Long ' source file exists in destination folder
Dim BlanksCount As Long ' blank cell
Dim sExt As String 'extension (dot inclusive)
For r = fRow To lRow
sPartialFileName = CStr(ws.cells(r, Col).Value)
sExt = CStr(ws.cells(r, colExt).Value)
If Len(sPartialFileName) > 3 Then ' the cell is not blank
' 'Begins with' sPartialFileName
sFileName = Dir(sFolderPath & sPartialFileName & "*" & sExt)
Do While sFileName <> ""
If Len(sFileName) > 3 Then ' source file found
sFilePath = sFolderPath & sFileName
dFilePath = dFolderPath & sFileName
If Not fso.FileExists(dFilePath) Then ' the source file...
fso.CopyFile sFilePath, dFilePath ' ... doesn't exist...
sYesCount = sYesCount 1 ' ... in the destination
Else ' the source file exists in the destination folder
dYesCount = dYesCount 1
End If
Else ' the source file doesn't exist
sNoCount = sNoCount 1
End If
sFileName = Dir
Loop
Else ' the cell is blank
BlanksCount = BlanksCount 1
End If
Next r
End Sub
請在測驗后發送一些反饋。
轉載請註明出處，本文鏈接：https://www.uj5u.com/qiye/534677.html
標籤：VBA文件系统对象