如何遍歷檔案夾A的子檔案夾以獲取每個子檔案夾中的檔案名并使用VBA從檔案夾B復制其他同名檔案

檔案夾 A 包含多個子檔案夾，如 A1、A2、A3 等，每個子檔案夾大多有一個有時是 2 個單詞的檔案，其中包含名稱（例如 file_a1）。然后，還有其他檔案夾 B（不是 A 的子檔案夾），其中包含多個具有標準相似 (file_a1_XZ) 名稱的單詞檔案。我想在 A 的子檔案夾中回圈并將 word 檔案從 B 復制到相應的子檔案夾，例如 A1

檔案結構：

Parent Folder
|
|
 ----Parent B
     |
     |
      --- B
          |
           -file_a1_XZ
           -file_a2_XZ
 ----Parent A
     |
     |
      --- A
          |
          |
           -- A1
              |
               -file_a1
           -- A2
              |
               -file_a2

uj5u.com熱心網友回復：

將檔案移動到特定檔案夾使用Dir

• 將檔案移動B到子檔案夾，A即檔案名包含子檔案夾的名稱。

Option Explicit

Sub MoveFiles()
    
    Const sFolderPath As String = "C:\Test\T2022\71752347\B\"
    Const dFolderPath As String = "C:\Test\T2022\71752347\A\"
    Const sExtensionPattern As String = ".doc*"
    
    Dim dFolderName As String: dFolderName = Dir(dFolderPath, vbDirectory)
    
    Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary")
    
    Do Until Len(dFolderName) = 0
        If dFolderName <> "." And dFolderName <> ".." Then
            dict(dFolderName) = Empty
        End If
        dFolderName = Dir
    Loop
    
    Dim Key As Variant
    Dim sFileName As String
    Dim fCount As Long
    
    For Each Key In dict.Keys
        
        sFileName = Dir(sFolderPath & "*" & Key & "*" & sExtensionPattern)
        
        Do Until Len(sFileName) = 0
            fCount = fCount   1
            FileCopy sFolderPath & sFileName, _
                dFolderPath & Key & "\" & sFileName
            Kill sFolderPath & sFileName
            sFileName = Dir
        Loop
    
    Next

    MsgBox "Files moved: " & fCount, vbInformation

End Sub

• 如果 B 中的檔案位于各個子檔案夾中，請使用以下內容。

Sub MoveFiles()
    
    Const sFolderPath As String = "C:\Test\T2022\71752347\B\"
    Const dFolderPath As String = "C:\Test\T2022\71752347\A\"
    Const sExtensionPattern As String = ".doc*"
    
    Dim dFolderName As String: dFolderName = Dir(dFolderPath, vbDirectory)
    
    Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary")
    
    Do Until Len(dFolderName) = 0
        If dFolderName <> "." And dFolderName <> ".." Then
            dict(dFolderName) = Empty
        End If
        dFolderName = Dir
    Loop
    
    Dim sFilePaths() As String
    Dim sFilePath As String
    Dim dFilePath As String
    Dim Key As Variant
    Dim f As Long
    Dim fCount As Long
    
    For Each Key In dict.Keys
        sFilePaths = ArrFilePaths(sFolderPath, _
            "*" & Key & "*" & sExtensionPattern)
        For f = 0 To UBound(sFilePaths)
            fCount = fCount   1
            sFilePath = sFilePaths(f)
            dFilePath = dFolderPath & Key & "\" & Right(sFilePath, _
                Len(sFilePath) - InStrRev(sFilePath, "\"))
            FileCopy sFilePath, dFilePath
            Kill sFilePath
        Next f
    Next Key
        
    MsgBox "Files moved: " & fCount, vbInformation

End Sub

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose:      Returns the file paths of the files in a folder
'               in a zero-based string array.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function ArrFilePaths( _
    ByVal FolderPath As String, _
    Optional ByVal FilePattern As String = "*.*", _
    Optional ByVal DirSwitches As String = "/s/b/a-d") _
As String()
    Const ProcName As String = "ArrFilePaths"
    On Error GoTo ClearError
    
    ' Ensuring that a string array is passed if an error occurs.
    ArrFilePaths = Split("") ' LB = 0 , UB = -1
   
    Dim pSep As String: pSep = Application.PathSeparator
    If Right(FolderPath, 1) <> pSep Then FolderPath = FolderPath & pSep
    Dim ExecString As String ' '%comspec%' or 'cmd.exe' ?
    ExecString = "%comspec% /c Dir """ _
        & FolderPath & FilePattern & """ " & DirSwitches
    Dim Arr() As String: Arr = Split(CreateObject("WScript.Shell") _
        .Exec(ExecString).StdOut.ReadAll, vbCrLf)
    If UBound(Arr) > 0 Then
        ReDim Preserve Arr(0 To UBound(Arr) - 1)
    End If
    ArrFilePaths = Arr

ProcExit:
    Exit Function
ClearError:
    Debug.Print "'" & ProcName & "' Run-time error '" _
        & Err.Number & "':" & vbLf & "    " & Err.Description
    Resume ProcExit
End Function

標籤：vba 循环 文件 自动化

上一篇：運行時錯誤13之前成功運行的程式模塊中的型別不匹配

下一篇：請ExcelVBA幫助