如何創建 VBA 宏，它將數據從文件夾中的多個源工作簿復制到另一個工作簿，然后另存為新工作簿

Question

關於我需要幫助的內容的更多背景信息。 我需要創建一個 VBA 宏，該宏將從工作表中復制特定行並將其粘貼到另一個工作表中。 此后將文件另存為新工作簿。 我需要確保這個 VBA 是一個數組，這意味着這需要在一個文件夾中的許多工作簿上完成。 那是。 對於每個源工作簿復制數據行，將其粘貼到主工作簿中並將工作簿另存為新工作簿。 話雖如此，我需要 10 個主工作簿，因為有 10 個源工作簿。

這是我的工作簿所在的位置

這是源工作簿文件的示例，如下所示。 我只需要復制沒有標題的數據，所以第 2 行。這需要對上面文件夾中的所有文件進行。 所有文件都具有相同的布局，只有第 2 行與數據所在的位置相同。

主/目標工作簿如下所示，應粘貼數據的行是第 9 行。此模板化工作簿位於不同的文件夾中。

下面是我當前使用的代碼，它將源文件夾中多個工作簿中的數據行添加到主工作簿中，但是這會增加行數。 我需要有關如何為每個源工作簿創建新的主工作簿的幫助，然后以源工作簿名稱作為后綴保存主工作簿示例“主工作簿-AAAA”.xlsx

Option Explicit
Const FOLDER_PATH = "C:\Users\\Desktop\Split Files\"  'REMEMBER END BACKSLASH' 

子 ImportWorksheets()
'處理指定文件夾中的所有 Excel 文件'
Dim sFile As String '要處理的文件
將 wsTarget 調暗為工作表
將 wbSource 調暗為工作簿
將 wsSource 調暗為工作表
Dim rowTarget As Long '輸出行

       rowTarget = 9

       'check the folder exists    
      If Not FileFolderExists(FOLDER_PATH) Then
      MsgBox "Specified folder does not exist, exiting!"
      Exit Sub   
      End If

       'reset application settings in event of error'    
        On Error GoTo errHandler    
       Application.ScreenUpdating = False

       'set up the target worksheet'    
       Set wsTarget = Sheets("DATABASE")

       'loop through the Excel files in the folder'    
       sFile = Dir(FOLDER_PATH & "*.xls*")    
       Do Until sFile = ""
      
      'open the source file and set the source worksheet - ASSUMED WORKSHEET(1)
      Set wbSource = Workbooks.Open(FOLDER_PATH & sFile)
      Set wsSource = wbSource.Worksheets(1)
      
      'import the data'
      With wsTarget
         .Range("A" & rowTarget).Value = wsSource.Range("A2").Value
         .Range("B" & rowTarget).Value = wsSource.Range("B2").Value
         .Range("C" & rowTarget).Value = wsSource.Range("C2").Value
         .Range("D" & rowTarget).Value = wsSource.Range("D2").Value
         .Range("E" & rowTarget).Value = wsSource.Range("E2").Value
         .Range("F" & rowTarget).Value = wsSource.Range("F2").Value
         .Range("G" & rowTarget).Value = wsSource.Range("G2").Value
         .Range("H" & rowTarget).Value = wsSource.Range("H2").Value
         .Range("I" & rowTarget).Value = wsSource.Range("I2").Value
      End With
      
      'close the source workbook, increment the output row and get the next file'
      wbSource.Close SaveChanges:=False
      rowTarget = rowTarget + 1
      sFile = Dir()    
      Loop

    errHandler:    
    On Error Resume Next   
    Application.ScreenUpdating = True

       'tidy up'    
         Set wsSource = Nothing    
         Set wbSource = Nothing     
         Set wsTarget = Nothing 
       End Sub 

私有 Function FileFolderExists(strPath As String) As Boolean If Not Dir(strPath, vbDirectory) = vbNullString Then FileFolderExists = True End Z864085503C34AF726FDD9F8B0

結果如下所示

只是更新..

我嘗試了一種不同的方法，如下所示。 但是，工作簿正在崩潰。 知道我在做什么錯嗎？

Answer 1

 'open template
    Const MASTER = "path-to-file\master.xlsx"
    Set wbTarget = Workbooks.Open(MASTER)
    Set wsTarget = wbTarget.Sheets(1)
    wsTarget.Unprotect "password"

    Do While sFile <> ""

        ' read source
        Set wbSource = Workbooks.Open(sFolder & sFile, 1, 1) ' update links, readonly
        Set wsSource = wbSource.Sheets(1)

        ' create target
        wsTarget.Name = "DATABASE"
        wsTarget.Range("A" & ROW_TARGET).Resize(1, 9) = wsSource.Range("A2:I2").Value2
        wbTarget.SaveAs "path\to\Master_" & sFile
        wbSource.Close False
    
        sFile = Dir

    Loop
    wsTarget.protect "password"
    wbTarget.Close False