Excel VBA打開和合並許多工作簿

Question

我想合並許多（超過2打）數據集，每組15000行和36列。 這些數據集具有相同的列，或多或少具有相同的行。 它們是相同數據的每月快照，其中一些數據離開而一些數據進入（因此，行數略有不同）。

我希望用戶選擇其中一些並將其組合。 文件名包含該日期，我的代碼提取該日期並將其添加到末尾的新列中。 現在，我的代碼起作用了。 我將所有數據收集到三維數組中，然后將其粘貼到新的工作簿中。 問題在於，由於每本書都有不同的編號或行數，因此我創建的數據數組的行數超出了需要。 因此，我的數據現在有很多Empy行。 我想我可以最后刪除空行。 我是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