Excel VBA 打开和合并许多工作簿

Question

我有很多，超过两打（并且还在增加）数据集，每个数据集有 15000 行和 36 列，我想合并它们。这些数据集具有相同的列和或多或少相同的行。它们是相同数据的每月快照，有些数据离开，有些数据进入（因此行数略有不同。

我希望用户选择其中一些并将它们组合起来。文件名包含该日期，我的代码提取日期并将其添加到末尾的新列中。现在，我的代码有效。我将所有数据收集在一个三维数组中，然后将其粘贴到一个新工作簿中。问题是，由于每本书都有不同的数字或行，我正在创建一个数据数组，其中的行数比需要的多。所以我的数据现在有很多空行。我想我最终可以删除空行。我是 excel VBA 的新手，也是数据工作的新手，所以我想知道是否有更智能、更有效的方式来构建我的面板。

Dim DataArray As Variant


Sub test()
    Dim filespec As Variant, i As Integer

     ReDim DataArray(0 To 20000, 0 To 36, 0 To 0)

    ' Here the user gets to select the files 
    On Error GoTo EndNow
    filespec = Application.GetOpenFilename(FileFilter:="microsoft excel files (*.xls), *.xls", Title:="Get File", MultiSelect:=True)

    For i = 1 To UBound(filespec)
         ReDim Preserve DataArray(0 To 20000, 0 To 36, 0 To i)
        Set wbSource = Workbooks.Open(filespec(i))
        Set ws1 = wbSource.Worksheets("Sheet1")
        With ws1
                'now I store the values in my array
                FinalColumn = .Cells(1, .Columns.Count).End(xlToLeft).Column
                FinalRow = .Range("B" & .Rows.Count).End(xlUp).Row
                For j = 1 To FinalRow
                     For k = 1 To FinalColumn
                          DataArray(j, k, i) = .Cells(j, k).Value
                     Next k
                     ' Now I extract the date data from the file name and store it in the last column of my array.
                     DataArray(j, FinalColumn + 1, i) = piece(piece(GetFileName(CStr(filespec(i))), "_", 3), ".", 1)
                 Next j
        End With

       ActiveWorkbook.Close


    Next i

     Set wb2 = Application.Workbooks.Add
           Set ws2 = wb2.Worksheets("Sheet1")

           With ws2

         For i = 1 To UBound(DataArray, 3)
           FinalRow2 = 20000
           FinalColumn2 = 36

           For k = 1 To FinalColumn2

               ' I did this If loop so as to not copy headers every time.
               If i = 1 Then
                For j = 1 To FinalRow2
                     .Cells(j, k).Value = DataArray(j, k, i)

                 Next j
               Else
                 For j = 2 To FinalRow2
                     .Cells(FinalRow2 * (i - 1) + j, k).Value = DataArray(j, k, i)

                 Next j
                 End If


          Next k

           Next i


           wb2.Sheets(1).Name = "FolderDetails Panel Data"

                        wb2.SaveAs ThisWorkbook.Path & "Folder_Details_Panel_Data" & "_" & Format(Date, "yyyy_mm_dd"), _
                FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False



           End With


EndNow:
End Sub

 ' MsgBox GetFileName(filespec(0))
Function GetFileName(filespec As String)
    Dim fso As Object
    Set fso = CreateObject("Scripting.FileSystemObject")
    GetFileName = fso.GetFileName(filespec)
End Function

Function piece(Searchstring As String, Separator As String, IndexNum As Integer) As String
Dim t
t = Split(Searchstring, Separator)
If UBound(t) > 0 Then piece = t(IndexNum - 1)
End Function

Answer 1

为了回答您的直接问题，我会在处理每个工作簿时将数据从每个工作簿复制到合并的工作簿中。我认为将所有数据收集到 3D 数组中没有任何优势。

您的代码还有许多其他问题。接下来是对代码的重构，其中突出显示了更改。

Option Explicit  ' <-- Force declaration of all variables (must be first line in module)

Sub Demo()
    Dim filespec As Variant
    Dim i As Long  ' --> Long is prefered over Integer
    Dim DataArray As Variant ' <-- no need to be Module scoped
    ' --> Declare all your variables
    Dim j As Long, k As Long
    Dim wbSource As Workbook
    Dim ws As Worksheet
    Dim wbMerged As Workbook
    Dim wsMerged As Worksheet
    Dim DataHeader As Variant
    Dim FinalRow As Long, FinalColumn As Long
    Dim sDate As String
    Dim rng As Range

    ' Here the user gets to select the files
    On Error GoTo EndNow
    filespec = Application.GetOpenFilename(FileFilter:="microsoft excel files (*.xls), *.xls", Title:="Get File", MultiSelect:=True)
    If Not IsArray(filespec) Then
        ' <-- User canceled
        Exit Sub
    End If

    ' Speed up processing  <--
    ' -- Comment these out for debugging purposes
    'Application.ScreenUpdating = False
    'Application.Calculation = xlCalculationManual

    ' Create Merged Workbook
    Set wbMerged = Application.Workbooks.Add
    Set wsMerged = wbMerged.Sheets(1)
    wsMerged.Name = "FolderDetails Panel Data"

    For i = 1 To UBound(filespec)
        Set wbSource = Workbooks.Open(filespec(i))
        Set ws = wbSource.Worksheets("Sheet1")
        With ws
            FinalColumn = .Cells(1, .Columns.Count).End(xlToLeft).Column
            FinalRow = .Cells(.Rows.Count, 2).End(xlUp).Row
            If i = 1 Then
                ' Get header from first workbook only
                DataHeader = Range(.Cells(1, 1), .Cells(1, FinalColumn)).Value  ' <-- Get data header
                ReDim Preserve DataHeader(1 To 1, 1 To UBound(DataHeader, 2) + 1) ' <-- Range.Value arrays are 1 based
                k = UBound(DataHeader, 2)
                DataHeader(1, k) = "Date" ' <-- Header
            End If
            ' Get all data in one go, excluding header
            DataArray = Range(.Cells(2, 1), .Cells(FinalRow, FinalColumn)).Value  ' <-- Array size matches data size
        End With
        wbSource.Close False

        ' Add Date to data
        sDate = GetDateFromFileName(filespec(i)) '<-- do it once
        ' resize data array
        ReDim Preserve DataArray(1 To UBound(DataArray, 1), 1 To UBound(DataArray, 2) + 1) ' <-- Range.Value arrays are 1 based
        ' Add date data
        For j = 1 To UBound(DataArray, 1)
            DataArray(j, k) = sDate
        Next j

        ' Complete processing of each workbook as its opened
        With wsMerged
            ' Add header row from first workbook
            If i = 1 Then
                Range(.Cells(1, 1), .Cells(1, UBound(DataArray, 2))) = DataHeader
            End If

            ' <-- Add data to end of sheet
            ' Size the destination range to match the data
            Set rng = .Cells(.Rows.Count, 2).End(xlUp).Offset(1, -1)
            Set rng = rng.Resize(UBound(DataArray, 1), UBound(DataArray, 2))
            rng = DataArray

        End With
    Next i
    '  <-- append \ to path
    wbMerged.SaveAs ThisWorkbook.Path & "\" & "Folder_Details_Panel_Data" & "_" & Format(Date, "yyyy_mm_dd"), _
      FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
CleanUp:
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
Exit Sub
EndNow:
    MsgBox "Oh dear"

    GoTo CleanUp
End Sub

' Simplified
' <-- Not entirely sure if this will match your file name pattern.
'     Please check
' Assumed file name
'    Some\Path\Some_Words_YYYMMDD.xls
Function GetDateFromFileName(Nm As Variant) As String
    Dim str As String
    str = Mid$(Nm, InStrRev(Nm, "\") + 1)
    str = Left$(str, InStrRev(str, ".") - 1)
    str = Mid$(str, InStrRev(str, "_") + 1)
    GetDateFromFileName = str
End Function