使用VBA将多个xls文件数据复制到单个文件

我在一个文件夹中有多个文件。我想将所有文件数据（即所有列复制到新工作表）复制到一个新工作表。 例如，文件1包含5列数据，文件2包含10列数据，依此类推。这些数据应该复制到新的工作表上，就像前5列来自文件1，然后在第6列的同一工作表上，文件2数据应该复制，依此类推

我尝试过，但遇到了一些问题，例如我能够成功复制第一个文件数据，但当我要复制第二个文件时，第二个文件数据会覆盖第一个文件。我想要第二个文件数据到下一列

下面是我的代码

Public Sub CommandButton1_Click()
'DECLARE AND SET VARIABLES
Dim wbk As Workbook
Dim Filename As String
Dim Path As String
Dim mainwb As Workbook
Dim ws As Worksheet
 Dim search_result As Range   'range search result
    Dim blank_cell As Long
Dim wb As Workbook
Path = "C:\Test\"
Filename = Dir(Path & "*.xls")
'--------------------------------------------
'OPEN EXCEL FILES
 Do While Len(Filename) > 0  'IF NEXT FILE EXISTS THEN
    Set wbk = Workbooks.Open(Path & Filename)
    Set wbk = ActiveWorkbook
     sheetname = ActiveSheet.Name
    wbk.Sheets(sheetname).Activate

Lastrow = ActiveSheet.Range("A" & Rows.Count).End(xlUp).Row

For i = 1 To Lastrow

 wbk.Sheets(sheetname).UsedRange.Copy

   Workbooks("aaa.xlsm").Activate
   Set wb = ActiveWorkbook
  sheetname1 = ActiveSheet.Name
 Lastrow = ActiveSheet.Range("A" & Rows.Count).End(xlUp).Row
wb.Sheets(sheetname1).Range("A1").Select
wb.Sheets(sheetname1).Paste
  Next i
 ActiveCell.Offset(0, 1).Select

    wbk.Close SaveChanges:=False
    Filename = Dir
Loop
End Sub

请帮帮我。。。。。。

---

提前感谢使用

For i=1 To Lastrow

循环，您将内容粘贴了几次，我无法在没有重大更改的情况下更正它。因此，我建议使用下面的示例，我添加了一些注释来描述正在发生的事情

Public Sub Sample()
Dim Fl          As Object
Dim Fldr        As Object
Dim FSO         As Object
Dim LngColumn   As Long
Dim WkBk_Dest   As Excel.Workbook
Dim WkBk_Src    As Excel.Workbook
Dim WkSht_Dest  As Excel.Worksheet
Dim WkSht_Src   As Excel.Worksheet

'Using FileSystemObject to get the folder of files
Set FSO = CreateObject("Scripting.FileSystemObject")
Set Fldr = FSO.GetFolder("C:\Users\Gary\Desktop\New folder\")

'Setting a reference to the destination worksheet (i.e. where the
'data we are collecting is going to)
Set WkBk_Dest = ThisWorkbook
Set WkSht_Dest = WkBk_Dest.Worksheets("Sheet1")

'Look at each file in the folder
For Each Fl In Fldr.Files

    'Is it a xls, xlsx, xlsm, etc...
    If InStr(1, Right(Fl.Name, 5), ".xls") <> 0 Then

        'Get the next free column in our destination
        LngColumn = WkSht_Dest.Cells(1, WkSht_Dest.Columns.Count).End(xlToLeft).Column
        If LngColumn > 1 Then LngColumn = LngColumn + 1

        'Set a reference to the source (note in this case it is simply selected the first worksheet
        Set WkBk_Src = Application.Workbooks.Open(Fl.Path)
        Set WkSht_Src = WkBk_Src.Worksheets(1)

            'Copy the data from source to destination
            WkSht_Src.UsedRange.Copy WkSht_Dest.Cells(1, LngColumn)

        Set WkSht_Src = Nothing
        WkBk_Src.Close 0
        Set WkBk_Src = Nothing
    End If
Next

Set WkSht_Dest = Nothing

Set WkBk_Dest = Nothing
Set Fldr = Nothing
Set FSO = Nothing

End Sub

Public子示例（）
作为对象的Dim Fl
作为对象的Dim Fldr
作为对象的Dim FSO
昏暗的LngColumn如长
将WkBk\u Dest设置为Excel.工作簿
Dim WkBk_Src作为Excel.工作簿
将WkSht\u Dest设置为Excel.工作表
Dim WkSht_Src作为Excel.工作表
'使用FileSystemObject获取文件文件夹
设置FSO=CreateObject（“Scripting.FileSystemObject”）
设置Fldr=FSO.GetFolder（“C:\Users\Gary\Desktop\newfolder\”）
'设置对目标工作表的引用（即
“我们正在收集的数据将
设置WkBk_Dest=此工作簿
设置WkSht_Dest=WkBk_Dest.工作表（“表1”）
'查看文件夹中的每个文件
对于Fldr.文件中的每个Fl
“是xls、xlsx、xlsm等。。。
如果指令（1，右（Fl.Name，5），“.xls”）为0，则
'获取目标中的下一个空闲列
LngColumn=WkSht目的单元格（1，WkSht目的列.Column）.End（xlToLeft）.Column
如果LngColumn>1，则LngColumn=LngColumn+1
'设置对源的引用（注意，在本例中，仅在第一张工作表中选择它
设置WkBk_Src=Application.Workbooks.Open（Fl.Path）
设置WkSht_Src=WkBk_Src.工作表（1）
'将数据从源复制到目标
WkSht_Src.UsedRange.Copy WkSht_Dest.单元格（1，LngColumn）
设置WkSht_Src=Nothing
WkBk_Src.Close 0
设置WkBk_Src=Nothing
如果结束
下一个
设置WkSht\u Dest=Nothing
设置WkBk_Dest=Nothing
设置Fldr=无
设置FSO=无
端接头

您还需要提升列值。在行

wb.Sheets（sheetname1）.Range（“A1”）。选择

，您需要将A1修改为B1和C1等。每次打开新工作簿（Excel文件）时，使用一个简单的循环将列提升1。我不明白你为什么要使用For i=1到Lastrow循环。我不明白你在说什么……你能不能修改我的代码并发布它……谢谢你的回答。老实说，你的代码是以一种无法修复的方式编写的，我已经尝试过了。它需要重新编写，但即使这样也会让你今天有工作，因为不清楚其中的一些问题是什么我们试图实现的行。感谢您的回答……我得到了答案，我刚刚在“下一个i”单元格（Selection.Row，Columns.Count）旁边添加了一行。End（xlToLeft）。Offset（，1）。选择“……现在代码已成功运行