Merge Excel workbooks to one Worksheet

问题

I am trying to merge 250 database excel workbooks into one continuous worksheet. All of the workbooks have the same kind of data, with the same headers.

I have tried using this VBA code:

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

The code works fine, but it creates a new sheet for every workbook, instead of copying the data to the bottom row of 1 sheet.

回答1:

I prepared a very fast method of data moving (using arrays and working in memory), avoiding Copy and Paste.

1. Copy this new declarations at your declarations area:

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

2. Copy this code line before the loop (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. Replace (in the loop For Each ...) the existing code (tempWorkSheet.Copy after:=mainWorkbook.Sheets(mainWorkbook.Worksheets.Count)) with the next one:

   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

My solution will copy all sheet content (headers included) in case of empty sheet to collect data and after that, data range starting from the second row.

Your full code as it should be in order to work (untested):

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

回答2:

I used following macro to combine many CSV files in one worksheet in a new workbook.. You may need to make some changes to suit your need

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

来源：https://stackoverflow.com/questions/60295436/merge-excel-workbooks-to-one-worksheet