将Excel工作簿合并到一个工作表 [英] Merge Excel workbooks to one Worksheet

问题描述

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

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.

我尝试使用此VBA代码:

I have tried using this VBA code:

子mergeFiles() 将文件夹中的所有文件合并到主文件中.

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

结束子

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

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.

推荐答案

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

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

1. 将此新的声明复制到您的声明区域:

1. Copy this new declarations at your declarations area:

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

在循环(For i = 1 To ...)之前复制以下代码行:

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

用下一个替换(在循环For Each ...中)现有代码(tempWorkSheet.Copy after:=mainWorkbook.Sheets(mainWorkbook.Worksheets.Count)):

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

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

这篇关于将Excel工作簿合并到一个工作表的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！