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

Question

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

我已尝试使用此 VBA 代码：

Sub mergeFiles()
    'Merges all files in a folder to a main file.
    
    '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
    
End Sub

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

Answer 1

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

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

   Dim sh As Worksheet, arrCopy As Variant, lastR As Long

2. 在循环之前复制此代码行 (For i = 1 To ...)：

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

3. 将现有代码 (tempWorkSheet.Copy after:=mainWorkbook.Sheets(mainWorkbook.Worksheets.Count)) 替换为下一个代码：

   lastR = sh.Range("A" & sh.Rows.count).End(xlUp).row

   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

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

您的完整代码应该是为了工作（未经测试）：

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

Answer 2

我使用以下宏将许多 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