我有這個 Excel VBA 腳本，它可以根據 Excel 中的串列將檔案從一個檔案夾移動到另一個檔案夾。但是，我必須逐個子檔案夾來獲取檔案。我想修改腳本，使其從主檔案夾（包含子檔案夾）中搜索檔案，并將相應的檔案移動到另一個主檔案夾中包含的相應子檔案夾，其檔案夾結構與原始主檔案夾相同。
我原來的檔案夾結構是：
Main Folder1
|
|______fold1
| |_____file1.wav
| |_____file2.wav
|
|______fold2
| |_____file1.wav
| |_____file2.wav
|
|______fold3
|_____file1.wav
|_____file2.wav
這是移動到檔案夾結構：
Moved2Folder
|
|______fold1
|
|______fold2
|
|______fold3
這是我在單個檔案夾上使用的 move 2 腳本：
Dim xVal As String
On Error Resume Next
Set xRg = Application.InputBox("Please select the file names:", "BoBO Man", ActiveWindow.RangeSelection.Address, , , , , 8)
If xRg Is Nothing Then Exit Sub
Set xSFileDlg = Application.FileDialog(msoFileDialogFolderPicker)
xSFileDlg.Title = " Please select the original folder:"
If xSFileDlg.Show <> -1 Then Exit Sub
xSPathStr = xSFileDlg.SelectedItems.Item(1) & "\"
Set xDFileDlg = Application.FileDialog(msoFileDialogFolderPicker)
xDFileDlg.Title = " Please select the destination folder:"
If xDFileDlg.Show <> -1 Then Exit Sub
xDPathStr = xDFileDlg.SelectedItems.Item(1) & "\"
For Each xCell In xRg
xVal = xCell.Value
If TypeName(xVal) = "String" And xVal <> "" Then
FileCopy xSPathStr & xVal, xDPathStr & xVal
Kill xSPathStr & xVal
End If
Next
End Sub
如何正確地將找到的檔案從 Main Folder1 子檔案夾移動到相應的 Moved2Folder 子檔案夾？
請注意，自上周以來，我已在Excel 先生網站上發布了此問題，但迄今為止尚未收到任何回復。
任何幫助將不勝感激！
uj5u.com熱心網友回復：
這樣的事情應該這樣做：
Sub CopySelected()
Dim rngFileNames As Range, srcPath As String, destPath As String
Dim colFiles As Collection, f
On Error Resume Next
Set rngFileNames = Application.InputBox("Please select the file names:", _
"BoBO Man", ActiveWindow.RangeSelection.Address, , , , , 8)
On Error GoTo 0
If rngFileNames Is Nothing Then Exit Sub
srcPath = GetFolderPath("Please select the original folder:")
If Len(srcPath) = 0 Then Exit Sub
destPath = GetFolderPath("Please select the destination folder:")
If Len(destPath) = 0 Then Exit Sub
Set colFiles = GetMatches(srcPath, "*") 'get all source folder files
For Each f In colFiles 'loop source folder files
'does the file name match one of the selected names?
If Not IsError(Application.Match(f.Name, rngFileNames, 0)) Then
f.Copy Replace(f.Path, srcPath, destPath) 'copy this file
End If
Next f
End Sub
'get a folder from the user - returns empty string if no selection
Function GetFolderPath(msg As String) As String
With Application.FileDialog(msoFileDialogFolderPicker)
.Title = msg
If .Show = -1 Then GetFolderPath = .SelectedItems.Item(1) & "\"
End With
End Function
'Return a collection of file objects given a starting folder and a file pattern
' e.g. "*.txt"
'Pass False for last parameter if don't want to check subfolders
Function GetMatches(startFolder As String, filePattern As String, _
Optional subFolders As Boolean = True) As Collection
Dim fso, fldr, f, subFldr, fpath
Dim colFiles As New Collection
Dim colSub As New Collection
Set fso = CreateObject("scripting.filesystemobject")
colSub.Add startFolder
Do While colSub.Count > 0
Set fldr = fso.GetFolder(colSub(1))
colSub.Remove 1
If subFolders Then
For Each subFldr In fldr.subFolders
colSub.Add subFldr.Path
Next subFldr
End If
fpath = fldr.Path
If Right(fpath, 1) <> "\" Then fpath = fpath & "\"
f = Dir(fpath & filePattern) 'Dir is faster...
Do While Len(f) > 0
colFiles.Add fso.GetFile(fpath & f)
f = Dir()
Loop
Loop
Set GetMatches = colFiles
End Function
轉載請註明出處，本文鏈接：https://www.uj5u.com/houduan/476881.html
下一篇：過濾從excel中提取的IP檔案