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（它是右括号之前的最后一个）。实际上，您可能为此设置了变量lMaxTargetColumn。但是，我不会检查每个循环中的最后一列。相反，我会在开始循环之前设置lTargetColumn = 1，然后在复制每个文件之后设置lTargetColumn = lTargetColumn + 3，除非您明确希望允许导入的文件具有可变列数，我将在其中考虑列.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

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

3 个答案: