将文件从 folders/subfolders 中找到的列表移动到另一个文件夹中的相同文件夹结构

Question

我有这个 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 子文件夹？

请注意，我从上周开始就在 Mr. Excel website here 上发布了这个问题，但到目前为止还没有收到任何回复。

任何帮助将不胜感激！

Answer 1

应该这样做：

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

将文件从 folders/subfolders 中找到的列表移动到另一个文件夹中的相同文件夹结构

MOVE files from list found in folders/subfolders to same folder structure in another folder

excel

vba

file

move