将多个文件复制到单个指定excel工作表的VBA代码

我开始学习VB编码（已经2天了）。到现在为止，一直都还不错。但是我需要帮助将多个文件从文件夹复制到单个指定工作表（或活动工作表）中。我在网上查了一下，基于这一点，我可以让它工作了。问题是在复制第一个文件后，下一个文件将被复制到第一个文件数据下面的行中。我想在下一列而不是最后一行中更改过去的代码。每个文件有3列，所以基本上File1数据将是前3列，然后file2将是第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

---

非常好！你快到了。错误在代码的这一行

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

lMaxTargetRow是刚刚重置的最后一行。负责最后一行+1的写入。事实上，我怀疑您每次都想写入第一行或第二行，只是另一列

为目标指定的列始终为1（它是右括号前的最后一个1）。实际上，设置变量lMaxTargetColumn可能就是为了这个目的。但是，我不会检查每个循环中的最后一列。相反，我会在开始循环之前设置

lTargetColumn=1

，然后在复制每个文件之后设置

lTargetColumn=lTargetColumn+3

，除非您明确希望允许导入的文件具有可变列计数，在这个过程中，我会考虑列。计数属性仍然比在任何你不知道它将在哪里的特定行中寻找空白区更可靠。

无论如何，如果您将上面的代码行更改为

Destination:=wTarget.Cells(1, lTargetColumn)

---

并为

lTargetColumn

添加适当的管理。您的代码应该执行您想要的操作。

为了将复制的数据正确粘贴到

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)

Dim LastCell作为范围
不执行时执行sFile=“”
设置wbkSource=Workbooks.Open（文件名：=sPath&sFile，AddToMRU:=False）
对于wbkSource.worksheet中的每个wSource
'====在循环中添加下面的查找代码，以查找最后占用的列=====
'使用“查找”获取wTarget sheet中数据最新的最后一个单元格
设置LastCell=wTarget.Cells.Find（What:=“*”，After:=wTarget.Cells（1,1），LookIn:=xlformals，LookAt:=_
xlPart，SearchOrder:=xlByColumns，SearchDirection:=xlPrevious，MatchCase:=False）
如果LastCell不算什么，那么“谢谢Shai的帮助。”
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