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

Question

I have many, over two dozen (and counting), data sets with 15000 rows and 36 columns each, that I would like to combine. These data sets are have the same columns and more or less the same rows. They are monthly snapshots of the same data, with some data leaving and some entering (hence the marginally different number of rows.

I would like the user to select some of them and and combine them. The name of the file contains that date and my code extracts the date and adds it in a new column at the end. Right now, my code works. I collect all the data in a three dimensional array and then paste it in a new workbook. The problem is that since each book has different numbers or rows, I am creating a data array with more rows than needed. So my data has a lot of empy rows right now. I guess I can delete the empty rows in the end. I am new to excel VBA and new to doing data work so I was wondering if there was a smarter, more efficient way of construction my panel.

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

To answer your direct question, I would copy the data from each workbook into the merged workbook as each is processed. I see no advantage in collecting all the data into a 3D array.

There are also many other issues with your code. What follows is a refactor of your code, with changes highlighted.

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