将Excel工作簿合并到一个工作表中

我正在尝试将250个数据库excel工作簿合并到一个连续的工作表中。 所有工作簿都具有相同类型的数据和相同的标题

我已尝试使用此VBA代码：

子文件（） '将文件夹中的所有文件合并到主文件

'Define variables:
Dim numberOfFilesChosen, i As Integer
Dim tempFileDialog As fileDialog
Dim mainWorkbook, sourceWorkbook As Workbook
Dim tempWorkSheet As Worksheet

Set mainWorkbook = Application.ActiveWorkbook
Set tempFileDialog = Application.fileDialog(msoFileDialogFilePicker)

'Allow the user to select multiple workbooks
tempFileDialog.AllowMultiSelect = True

numberOfFilesChosen = tempFileDialog.Show

'Loop through all selected workbooks
For i = 1 To tempFileDialog.SelectedItems.Count

    'Open each workbook
    Workbooks.Open tempFileDialog.SelectedItems(i)

    Set sourceWorkbook = ActiveWorkbook

    'Copy each worksheet to the end of the main workbook
    For Each tempWorkSheet In sourceWorkbook.Worksheets
        tempWorkSheet.Copy after:=mainWorkbook.Sheets(mainWorkbook.Worksheets.Count)
    Next tempWorkSheet

    'Close the source workbook
    sourceWorkbook.Close
Next i

端接头

---

代码工作正常，但它会为每个工作簿创建一个新的工作表，而不是将数据复制到工作表的底行

我使用以下宏将多个CSV文件合并到新工作簿中的一个工作表中。。您可能需要进行一些更改以满足您的需要

Sub GetFromCSVs()
  Dim WB As Workbook
  Dim R As Range
  Dim bFirst As Boolean
  Dim stFile As String
  Dim stPath As String
  stPath = "D:\CSV Files\" ' change the path to suit
  stFile = Dir(stPath & "*.csv")
  'bFirst = True
  Set R = Workbooks.Add(xlWorksheet).Sheets(1).Range("A1")
  Do Until stFile = ""
    Set WB = Workbooks.Open(stPath  & stFile, ReadOnly:=True)
    'If bFirst Then
     ' WB.Sheets(1).Range("A1").CurrentRegion.Copy Destination:=R
      WB.Sheets(1).Range(Selection, Range("A1").SpecialCells(xlLastCell)).Copy Destination:=R
      Set R = R.Offset(R.SpecialCells(xlLastCell).Row + 1 - R.Row, 0)

      'Set R = Range("A1").Offset(ActiveCell.SpecialCells(xlLastCell).Row, 0)
      'bFirst = False
    'Else
      'WB.Sheets(1).Range("A1").CurrentRegion.Columns(2).Copy Destination:=R
      'Set R = R.Offset(, 1)
    'End If
    WB.Close saveChanges:=False
    stFile = Dir()  ' next file
  Loop
End Sub

---

我准备了一种非常快速的数据移动方法（使用数组并在内存中工作），避免了复制和粘贴

在您的声明区域复制此新声明：

Dim sh作为工作表，arrCopy作为变量，lastR作为长度

将此代码行复制到循环之前（

对于i=1，复制到…

）：

Set sh=mainfoolk.Sheets（mainfoolk.Worksheets.count）”您可以在此处使用您的工作表来收集数据。为了便于测试，我使用了最后一页

将现有代码（

tempWorkSheet.Copy after:=mainWorkbook.Sheets（mainWorkbook.Worksheets.Count）

）替换为下一个代码（在循环中为每个…）：

lastR=sh.Range（“A”&sh.Rows.count）.End（xlUp）.row

arrCopy=tempsheet.Range（tempsheet.Range（“A”）和IIf（lastR=1,1,2））_
tempWorkSheet.Range（“A1”）.SpecialCells（xlLastCell））.Value
sh.Range（“A”&lastR+IIf（lastR=1,0,1））。调整大小（UBound（arrCopy，1）_
UBound（arrCopy，2））。Value=arrCopy

我的解决方案将复制所有工作表内容（包括标题），以收集空工作表中的数据，然后从第二行开始复制数据范围

您的完整代码正常工作（未经测试）：

子合并文件（）
'定义变量：
已选择Dim NumberOfFiles，i为整数
Dim tempFileDialog作为FileDialog
Dim主工作簿，源工作簿作为工作簿
将sh尺寸标注为工作表，将arrCopy作为变量，最后一个长度为
将临时工作表调整为工作表，最后一次调整为长
设置mainWorkbook=Application.ActiveWorkbook
设置tempFileDialog=Application.FileDialog（msoFileDialogFilePicker）
'允许用户选择多个工作簿
tempFileDialog.AllowMultiSelect=True
NumberOfFileSelected=tempFileDialog.Show
'您可以在此处使用工作表来收集数据。为了便于测试，我使用了最后一张纸
设置sh=mainfoolk.Sheets（mainfoolk.Worksheets.count）
'循环浏览所有选定的工作簿
对于i=1，请选择tempFileDialog.SelectedItems.count
'打开每个工作簿
工作簿。打开临时文件对话框。选择编辑项（i）
设置sourceWorkbook=ActiveWorkbook
'将每个工作表复制到主工作簿的末尾
Set tempWorkSheet=source工作簿。工作表（1）
lastR=sh.Range（“A”&sh.Rows.count）.End（xlUp）.row
lastRtemp=tempWorkSheet.Range（“A”&tempWorkSheet.Rows.count）.End（xlUp）.row
如果lastRtemp<2，则
MsgBox“工作簿”和tempWorkSheet.Name&“包含的两行更少…”
其他的
arrCopy=tempWorkSheet.Range（tempWorkSheet.Range（“A”&IIf（lastR=1,1,2））_
tempWorkSheet.Range（“A1”）.SpecialCells（xlLastCell））.Value
sh.Range（“A”&lastR+IIf（lastR=1,0,1））。调整大小（UBound（arrCopy，1）_
UBound（arrCopy，2））。值=arrCopy
如果结束
'关闭源工作簿
Source工作簿。关闭
接下来我
端接头

其行为与设计的代码完全相同：

tempsheet.Copy after:=mainWorkbook.Sheets（mainWorkbook.Worksheets.Count）

。。。您需要获取页面内容并将其删除。每次，在最后一行数据之后。我避免“复制”，因为这不是最好的方法。。。因此，是否要将图纸内容从第二行复制到包含数据的最后一行？它的所有列都填充到同一行？如果不是，哪一个被认为是引用（最长）？记住的一个事情是行限制Excel有每个表。如果超过该值，则会出现错误。工作簿的行数不同。所以我有工作手册：“车队A”，A到G列充满了车辆信息，比如VIN型号等等。工作簿组A可能包含50辆车（行），工作簿组B可能包含5000辆车。我想把所有的工作手册合并成一个连续的汽车文件（行）@AndreasKamper:我的问题不一样。。。让我换一种说法：在“舰队A”中，所有列都填充了同一行的数据？我的意思是，如果我计算A:A列的最后一个空行，这是否正确？此外，如果将移动数据的主工作簿中的工作表是空的（可能是第一次），则也会复制标题。从第二个文件开始，要移动的范围将从第二行（标题除外）开始，直到保留数据的最后一行（即使这个文件与另一个文件不同）。我的理解正确吗？这是正确的。我认为

Set WB=Workbooks.Open（stPath&stFile，ReadOnly:=True）

应该是

Set WB=Workbooks.Open（stFile，ReadOnly:=True）

，因为stFile已经定义为包含stPath，请注意它将复制源代码表中的列标题。如果您不想让他们使用注释掉的If条件

如果bFirst那么

在循环之前设置bFirst=true并更改循环代码之后当我尝试运行此代码时，它会打开一个新工作表，但不会从我的数据库添加任何数据。我应用错了吗？请检查文件扩展名我共享的代码是“*.csv”）。如果您的源文件是excel文件，请使用

stFile=Dir（stPath&“*.xls*”）

文件是.csvComments，不用于扩展讨论；这段对话已经结束了

Sub mergeFiles()
'Define variables:
Dim numberOfFilesChosen, i As Integer
Dim tempFileDialog As FileDialog
Dim mainWorkbook, sourceWorkbook As Workbook
Dim sh As Worksheet, arrCopy As Variant, lastR As Long
Dim tempWorkSheet As Worksheet, lastRtemp As Long

Set mainWorkbook = Application.ActiveWorkbook
Set tempFileDialog = Application.FileDialog(msoFileDialogFilePicker)

'Allow the user to select multiple workbooks
tempFileDialog.AllowMultiSelect = True

numberOfFilesChosen = tempFileDialog.Show

'You can use here your sheet where the data will be collected. I used the last sheet for easy testing reason
Set sh = mainWorkbook.Sheets(mainWorkbook.Worksheets.count)

    'Loop through all selected workbooks
    For i = 1 To tempFileDialog.SelectedItems.count

        'Open each workbook
        Workbooks.Open tempFileDialog.SelectedItems(i)

        Set sourceWorkbook = ActiveWorkbook

        'Copy each worksheet to the end of the main workbook
        Set tempWorkSheet = sourceWorkbook.Worksheets(1)
            lastR = sh.Range("A" & sh.Rows.count).End(xlUp).row
            lastRtemp = tempWorkSheet.Range("A" & tempWorkSheet.Rows.count).End(xlUp).row
            If lastRtemp < 2 Then
                MsgBox "The workbook " & tempWorkSheet.Name & " contains less the two rows..."
            Else
                arrCopy = tempWorkSheet.Range(tempWorkSheet.Range("A" & IIf(lastR = 1, 1, 2)), _
                  tempWorkSheet.Range("A1").SpecialCells(xlLastCell)).Value
                sh.Range("A" & lastR + IIf(lastR = 1, 0, 1)).Resize(UBound(arrCopy, 1), _
                                        UBound(arrCopy, 2)).Value = arrCopy
            End If

        'Close the source workbook
        sourceWorkbook.Close
    Next i
End Sub