VBA代碼將多個文件複製到單個指定的Excel表

Question

我開始學習VB編碼（已經2天）。到現在爲止還挺好。但我需要幫助將文件夾中的多個文件複製到單個指定的工作表（或活動工作表）中。我在網上查詢，並基於這一點，我能夠得到它的工作。問題是複製第一個文件後，下一個文件被複制到第一個文件數據下面的行中。我想更改下一列的代碼而不是最後一行。每個文件都是3列，所以基本上File1數據將是前3列，然後文件2將是列4-6，依此類推。這意味着每個數據的行都是相同的。我試圖修改代碼來實現這一點，但迄今沒有運氣...

Sub CombineMultipleFiles() 
' Path - modify as needed but keep trailing backslash 
    Const sPath = "C:\My_stuff\Test\" 
    Dim sFile As String 
    Dim wbkSource As Workbook 
    Dim wSource As Worksheet 
    Dim wTarget As Worksheet 
    Dim lRows As Long 
    Dim lMaxSourceRow As Long 
    Dim lMaxTargetRow As Long 
Dim lMaxTargetColumn As Long 
    'Dim blnNoHeader As Boolean 

    Application.ScreenUpdating = False 
    'lMaxTargetRow = 0 
    Set wTarget = ActiveSheet 
    lRows = wTarget.Rows.Count 
    sFile = Dir(sPath & "*.s1p*") 
    Do While Not sFile = "" 
    Set wbkSource = Workbooks.Open(Filename:=sPath & sFile, AddToMRU:=False) 
    For Each wSource In wbkSource.Worksheets 
    lMaxSourceRow = wSource.Cells(lRows, 1).End(xlUp).Row 
    lMaxTargetRow = wTarget.Cells(lRows, 1).End(xlUp).Row 
    wSource.Range("1:" & lMaxSourceRow).Copy _ 
     Destination:=wTarget.Cells(lMaxTargetRow + 1, 1) 
     Next 
    wbkSource.Close SaveChanges:=False 
    sFile = Dir 
    'MsgBox lMaxTargetRow 
    Loop 


    Application.ScreenUpdating = True 

End Sub 

Answer 1

很好！你快到了。錯誤出現在代碼的這一行中。

Destination:=wTarget.Cells(lMaxTargetRow + 1, 1) 

lMaxTargetRow是剛纔重置的最後一行。這是寫在最後一行+ 1負責。事實是，我懷疑你想寫每行第一或第二行，只是另一列。

爲目標指定的列始終爲1（它是右括號之前的最後1）。實際上，你可能爲此設置了變量lMaxTargetColumn。但是，我不會檢查每個循環中的最後一列。相反，在開始循環之前，我會設置lTargetColumn = 1，然後在複製每個文件之後設置lTargetColumn = lTargetColumn + 3，除非您明確要允許導入的文件具有變量列數，在這種情況下，我會認爲Columns.Count屬性仍然比在任何特定的行中尋找一個空白空間，你不知道它會在哪裏。

無論如何，如果你上面的代碼行更改爲

Destination:=wTarget.Cells(1, lTargetColumn) 

並添加相應的管理lTargetColumn你的代碼應該做你想要什麼。

Answer 2

爲了將正確複製的數據粘貼到wTarget中的第一個空列，您需要找到第一個空列。

您可以使用Find函數來實現此目的。

Dim LastCell As Range 

Do While Not sFile = "" 
    Set wbkSource = Workbooks.Open(Filename:=sPath & sFile, AddToMRU:=False) 
    For Each wSource In wbkSource.Worksheets 

     ' ===== add the Find code below inside your loop to find the last occupied column ===== 
     ' use Find to get the most updated last cell with data in wTarget sheet 
     Set LastCell = wTarget.Cells.Find(What:="*", After:=wTarget.Cells(1, 1), LookIn:=xlFormulas, LookAt:= _ 
     xlPart, SearchOrder:=xlByColumns, SearchDirection:=xlPrevious, MatchCase:=False) 

     If Not LastCell Is Nothing Then ' <-- if Find was successful 
      lMaxTargetColumn = LastCell.Column 
     Else ' <-- sheets is empty 
      lMaxTargetColumn = 1 
     End If 
     Set LastCell = Nothing 

     ' ==== when pasting use the logic below ==== 
     ' your copy line .... 
     Destination:=wTarget.Cells(1, lMaxTargetColumn + 1) 

Answer 3

Sub CombineMultipleFiles() 
' Path - modify as needed but keep trailing backslash 
    Const sPath = "C:\My_stuff" 
    Dim sFile As String 
    Dim wbkSource As Workbook 
    Dim wSource As Worksheet 
    Dim wTarget As Worksheet 
    Dim lRows As Long 
    Dim lMaxSourceRow As Long 
    Dim lMaxTargetRow As Long 
Dim lMaxTargetColumn As Long 
Dim lTargetColumn As Long 
    'Dim blnNoHeader As Boolean 

    Application.ScreenUpdating = False 
    'lMaxTargetRow = 0 
    Set wTarget = ActiveSheet 
    lRows = wTarget.Rows.Count 
    sFile = Dir(sPath & "*.s1p*") 
lTargetColumn = 1 
    Do While Not sFile = "" 
    Set wbkSource = Workbooks.Open(Filename:=sPath & sFile, AddToMRU:=False) 
    For Each wSource In wbkSource.Worksheets 
    lMaxSourceRow = wSource.Cells(lRows, 1).End(xlUp).Row 
    'MsgBox lMaxSourceRow 
    'lMaxTargetRow = wTarget.Cells(lRows, 1).End(xlUp).Row 
    wSource.Range("A:C").Copy _ 
    Destination:=wTarget.Cells(1, lTargetColumn) 
     lTargetColumn = lTargetColumn + 3 
     Next 
    wbkSource.Close SaveChanges:=False 
    sFile = Dir 
    'MsgBox lMaxTargetRow 
    'MsgBox "Done!" 
    Loop 


    Application.ScreenUpdating = True 

End Sub