使用 VBA 合并来自多个工作簿的数据

Question

如果这个问题已经被问过了，我很抱歉。我搜索了一下，只发现一个与我的情况有点相关的问题：如何合并数百个 Excel 电子表格文件？。

我修改了 Chris Kent 在链接帖子中提供的代码以尝试解决我的问题。

我在这里试图完成的是使用 Excel 2010 中的 VBA 从多个工作簿中提取特定范围的数据并将其粘贴到一个工作簿中。最后，我将添加每组数据总和的摘要页面。目前，我的主要问题是从多个工作簿中获取信息并成功复制。

每个工作簿上的每个范围都是相同的。

我并不需要拉动标题。

我只需要 1 张表的数据。

在我为了更好地满足我的需求而操作的代码中，我遇到了以下问题：

1. 前两个文件（日期 11-23-15 和 11-24-15）的数据没有被提取。我感觉这与我尚未触及的未编辑部分代码有关，这些代码涉及删除下面显示的带有 0 的列/行。

   Private Function GetTrueEnd(ws As Worksheet) As Range
       Dim lastRow As Long
       Dim lastCol As Long
       Dim r As Long
       Dim c As Long
   
       On Error Resume Next
       lastCol = ws.UsedRange.Find("*", , , xlPart, xlByColumns, xlPrevious).Column
       lastRow = ws.UsedRange.Find("*", , , xlPart, xlByRows, xlPrevious).Row
       On Error GoTo 0
   
       If lastCol <> 0 And lastRow <> 0 Then
   
           ' look back through the last rows of the table, looking for a non-zero value
           For r = lastRow To 1 Step -1
               For c = 1 To lastCol
                   If ws.Cells(r, c).Text <> "" Then
                       If ws.Cells(r, c).Text <> 0 Then
                           Set GetTrueEnd = ws.Cells(r, lastCol)
                           Exit Function
                       End If
                   End If
               Next c
           Next r
       End If
   
       Set GetTrueEnd = ws.Cells(1, 1)
   End Function
   

2. 第一个文件的日期（作为文件名）列在 B 列中，第二个文件的日期列在 C 列中，但它们应该列在 E 列中。这可能是我对#1 的相同假设的一部分。

3. 11-25-15 和 11-26-15 的数据有 #REF! 错误。我希望如果我弄清楚如何只提取值而不提取公式，就可以修复此错误。但是，其他日期都没有发生这种情况，所以我不确定这是否是潜在问题。我知道的唯一可以尝试使用“.Value”或“.Pastespecial”代码的地方如下，但我还没有让它工作：

   If mainLastEnd(i).Row > 1 Then
   ' There is data in the sheet
   
   ' Copy new data (skip headings)
           externWorkbook.Sheets(i).Range("A19:E23").Copy ThisWorkbook.Sheets(i).Cells(mainLastEnd(i).Row + 2, 1)
   

如果有人能帮助我解决上述问题，我将不胜感激。

以下是全部代码：

Option Explicit
Const NUMBER_OF_SHEETS = 1

Public Sub GiantMerge()
    Dim externWorkbookFilepath As Variant
    Dim externWorkbook As Workbook
    Dim i As Long
    Dim mainLastEnd(1 To NUMBER_OF_SHEETS) As Range
    Dim mainCurEnd As Range

    Application.ScreenUpdating = False

    ' Initialise

    ' Correct number of sheets
    Application.DisplayAlerts = False
    If ThisWorkbook.Sheets.Count < NUMBER_OF_SHEETS Then
        ThisWorkbook.Sheets.Add Count:=NUMBER_OF_SHEETS - ThisWorkbook.Sheets.Count
    ElseIf ThisWorkbook.Sheets.Count > NUMBER_OF_SHEETS Then
        For i = ThisWorkbook.Sheets.Count To NUMBER_OF_SHEETS + 1 Step -1
            ThisWorkbook.Sheets(i).Delete
        Next i
    End If
    Application.DisplayAlerts = True

    For i = 1 To NUMBER_OF_SHEETS
        Set mainLastEnd(i) = GetTrueEnd(ThisWorkbook.Sheets(i))
    Next i


    ' Load the data
    For Each externWorkbookFilepath In GetWorkbooks()
        Set externWorkbook = Application.Workbooks.Open(externWorkbookFilepath, , True)

        For i = 1 To NUMBER_OF_SHEETS

            If mainLastEnd(i).Row > 1 Then
                ' There is data in the sheet

                ' Copy new data (skip headings)
                externWorkbook.Sheets(i).Range("A19:E23").Copy ThisWorkbook.Sheets(i).Cells(mainLastEnd(i).Row + 2, 1)

                ' Find the end column and row
                Set mainCurEnd = GetTrueEnd(ThisWorkbook.Sheets(i))
            Else
                ' No data in sheet yet (prob very first run)

                ' Get correct sheet name from first file we check
                ThisWorkbook.Sheets(i).Name = externWorkbook.Sheets(i).Name


                ' Find the end column and row
                Set mainCurEnd = GetTrueEnd(ThisWorkbook.Sheets(i)).Offset(, 1)


            End If

            ' Add file name into extra column
            ThisWorkbook.Sheets(i).Range(ThisWorkbook.Sheets(i).Cells(mainLastEnd(i).Row + 1, mainCurEnd.Column), mainCurEnd).Value = externWorkbook.Name

            Set mainLastEnd(i) = mainCurEnd
        Next i

        externWorkbook.Close
    Next externWorkbookFilepath

    Application.ScreenUpdating = True
    End Sub

    ' Returns a collection of file paths, or an empty collection if the user selects cancel
    Private Function GetWorkbooks() As Collection
    Dim fileNames As Variant
    Dim xlFile As Variant

    Set GetWorkbooks = New Collection

    fileNames = Application.GetOpenFilename(Title:="Please choose the files to merge", _
                                               FileFilter:="Excel Files, *.xlsm;*.xlsx", _
                                               MultiSelect:=True)
    If TypeName(fileNames) = "Variant()" Then
        For Each xlFile In fileNames
            GetWorkbooks.Add xlFile
        Next xlFile
    End If
    End Function

    ' Finds the true end of the table (excluding unused columns/rows and rows filled with 0's)
    Private Function GetTrueEnd(ws As Worksheet) As Range
    Dim lastRow As Long
    Dim lastCol As Long
    Dim r As Long
    Dim c As Long

    On Error Resume Next
    lastCol = ws.UsedRange.Find("*", , , xlPart, xlByColumns, xlPrevious).Column
    lastRow = ws.UsedRange.Find("*", , , xlPart, xlByRows, xlPrevious).Row
    On Error GoTo 0

    If lastCol <> 0 And lastRow <> 0 Then

        ' look back through the last rows of the table, looking for a non-zero value
        For r = lastRow To 1 Step -1
            For c = 1 To lastCol
                If ws.Cells(r, c).Text <> "" Then
                    If ws.Cells(r, c).Text <> 0 Then
                        Set GetTrueEnd = ws.Cells(r, lastCol)
                        Exit Function
                    End If
                End If
            Next c
        Next r
    End If

    Set GetTrueEnd = ws.Cells(1, 1)
    End Function

Answer 1

我找到了另一个满足我需求的代码。我需要做一些调整，比如添加排序功能。

此代码获取了我想要打开的所有文件，复制了选择内容并粘贴到新工作表中，将所有数据合并到多个工作簿中的一个工作簿中。

它确实会在我运行代码的表单之外的新表单中打开数据，但这对我来说完全没问题。我可以选择保存它或只是打印它以供参考。

这是我从中获取该代码的链接，然后对其进行了修改以满足我的需求：

Ron de Bruin：工作簿示例：合并文件夹中所有工作簿的数据

代码如下：

Option Explicit


Sub Basic_Example_2()
    Dim MyPath As String
    Dim SourceRcount As Long, Fnum As Long
    Dim mybook As Workbook, BaseWks As Worksheet
    Dim sourceRange As Range, destrange As Range
    Dim rnum As Long, CalcMode As Long
    Dim SaveDriveDir As String
    Dim FName As Variant




FName = Application.GetOpenFilename(filefilter:="Excel Files (*.xl*), *.xl*", _
                                    MultiSelect:=True)
If IsArray(FName) Then

    'Add a new workbook with one sheet
    Set BaseWks = Workbooks.Add(xlWBATWorksheet).Worksheets(1)
    rnum = 1


    'Loop through all files in the array(myFiles)
    For Fnum = LBound(FName) To UBound(FName)
        Set mybook = Nothing
        On Error Resume Next
        Set mybook = Workbooks.Open(FName(Fnum))
        On Error GoTo 0

        If Not mybook Is Nothing Then

            On Error Resume Next
            With mybook.Worksheets(1)
                Set sourceRange = .Range("A19:E23")
            End With

            If Err.Number > 0 Then
                Err.Clear
                Set sourceRange = Nothing
            Else
                'if SourceRange use all columns then skip this file
                If sourceRange.Columns.Count >= BaseWks.Columns.Count Then
                    Set sourceRange = Nothing
                End If
            End If
            On Error GoTo 0

            If Not sourceRange Is Nothing Then

                SourceRcount = sourceRange.Rows.Count

                If rnum + SourceRcount >= BaseWks.Rows.Count Then
                    MsgBox "Sorry there are not enough rows in the sheet"
                    BaseWks.Columns.AutoFit
                    mybook.Close savechanges:=False
                    GoTo ExitTheSub
                Else

                    'Copy the file name in column A
                    With sourceRange
                        BaseWks.Cells(rnum, "A"). _
                                Resize(.Rows.Count).Value = FName(Fnum)
                    End With

                    'Set the destrange
                    Set destrange = BaseWks.Range("B" & rnum)

                    'we copy the values from the sourceRange to the destrange
                    With sourceRange
                        Set destrange = destrange. _
                                        Resize(.Rows.Count, .Columns.Count)
                    End With
                    destrange.Value = sourceRange.Value

                    rnum = rnum + SourceRcount
                End If
            End If
            mybook.Close savechanges:=False
        End If

    Next Fnum
    BaseWks.Columns.AutoFit
End If

ExitTheSub:

End Sub