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