我有很多，有二十多个（并且正在计数）数据集，每个数据集有15000行和36列，我想将它们结合起来。这些数据集具有相同的列，并且具有或多或少相同的行。它们是相同数据的月度快照，一些数据会离开，一些数据会进入（因此行数略有不同。
我希望用户选择其中一些并组合它们。该文件的名称包含该日期，我的代码提取日期并将其添加到最后的新列中。现在，我的代码有效。我收集三维数组中的所有数据，然后将其粘贴到新工作簿中。问题是，由于每本书都有不同的数字或行，我创建的数据数组的行数超过了所需的数量。所以我的数据现在有很多empy行。我想我最后可以删除空行。我是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
答案 0 :(得分：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