我正在研究這段代碼，它可以通過從 Excel 表中讀取名稱，完美地使用 (moveFilesFromListPartial) 將檔案從一個檔案夾復制到另一個檔案夾。但是，我需要幫助。
是否可以根據下面定義的標準將檔案從 1 個源檔案夾復制到兩個目標檔案夾。
例如 1 有 1 個源檔案夾和 2 個目標檔案夾 (Destination_1) 和 (Destination_2)。無論Sheet1單元格A1 到 A20中提到的名稱是什么，都應將其移至 Destination_2 檔案夾，并將所有剩余檔案移至 Destination_1 檔案夾。
我會一直心存感激
我的代碼在下面提到
Sub moveFilesFromListPartial_A()
Const sPath As String = "E:\Sourece"
Const dPath As String = "E:\Destination"
Const fRow As Long = 2
Const Col As String = "A"
' Reference the worksheet.
Dim ws As Worksheet: Set ws = Sheet1
' 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熱心網友回復：
從串列中復制檔案
- 建立在現有程式的基礎上會引發多種并發癥。
- 將任務拆分為更小的程序使代碼更具可讀性和可維護性。
- 這不使用
FileSystemObject物件，盡管它可以很容易地實作。
Sub CopyBeginsWith()
Const sPath As String = "E:\Source"
Const sUpAddress As String = "A2:A20"
Const dUpPath As String = "E:\Destination2"
Const dLowPath As String = "E:\Destination1"
Dim pSep As String: pSep = Application.PathSeparator
Dim ws As Worksheet: Set ws = Sheet1
' Copy from 1st (upper) range.
Dim rgUp As Range: Set rgUp = ws.Range(sUpAddress)
CopyFilesFromRangeBeginsWith rgUp, sPath, dUpPath, pSep
' Copy from 2nd (lower) range.
Dim rgLow As Range: Set rgLow = SetStackedBelowSingleColumnRange(rgUp)
If rgLow Is Nothing Then Exit Sub ' no data below 1st (upper) range
CopyFilesFromRangeBeginsWith rgLow, sPath, dLowPath, pSep
End Sub
Sub CopyFilesFromRangeBeginsWith( _
ByVal rg As Range, _
ByVal SourcePath As String, _
ByVal DestinationPath As String, _
Optional ByVal PathSeparator As String = "\")
Dim cell As Range
Dim FilePattern As String
For Each cell In rg.Cells
FilePattern = CStr(cell.Value) & "*" ' begins with
If Len(FilePattern) > 1 Then
CopyFilesUsingPattern FilePattern, SourcePath, _
DestinationPath, PathSeparator
End If
Next cell
End Sub
Sub CopyFilesUsingPattern( _
ByVal FilePattern As String, _
ByVal SourcePath As String, _
ByVal DestinationPath As String, _
Optional ByVal PathSeparator As String = "\")
Dim sFileName As String
sFileName = Dir(SourcePath & PathSeparator & FilePattern)
Dim sFilePath As String
Dim dFilePath As String
Do While Len(sFileName) > 0
sFilePath = SourcePath & PathSeparator & sFileName
dFilePath = DestinationPath & PathSeparator & sFileName
' Be aware that the following simplification 'hides' various errors,
' when e.g. invalid path, file is open... etc.
' i.e. not all files may be copied!
On Error Resume Next
FileCopy sFilePath, dFilePath ' overwrites existing files!
On Error GoTo 0
sFileName = Dir
Loop
End Sub
Function SetStackedBelowSingleColumnRange( _
ByVal SingleColumnRange As Range) _
As Range
' Uses the End property. Be aware of its shortcomings!
Dim rg As Range: Set rg = SingleColumnRange.Columns(1)
Dim ws As Worksheet: Set ws = rg.Worksheet
Dim fCell As Range: Set fCell = rg.Cells(rg.Cells.Count).Offset(1)
Dim lCell As Range: Set lCell = ws.Cells(ws.Rows.Count, rg.Column).End(xlUp)
If lCell.Row < fCell.Row Then Exit Function ' empty below first range
Set SetStackedBelowSingleColumnRange = ws.Range(fCell, lCell)
End Function
轉載請註明出處，本文鏈接：https://www.uj5u.com/gongcheng/526517.html
標籤：vba自动化
上一篇：使用復選框呼叫隱藏宏
下一篇：回圈遍歷作業表并過濾VBA