Question

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

我试过但面临一些问题，比如我能够成功复制第一个文件数据但是当我要去第二个文件时，第二个文件数据会覆盖第一个文件。我希望第二个文件数据到下一列。

以下是我的代码

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

请帮我...... 在此先感谢

Answer 1

使用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

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

1 个答案: