我有一个数组，它将它的值存储在排序列表中。我一直在使用这个排序列表来按日期在其他几个电子表格中组织数据。
我的源数据是一个工作簿中的一系列12个工作表。每个工作表反映一个日历月。交易/运行的数量是动态的 - 平均每月60个左右，所以我设置了200个循环的限制，因为这应该足以涵盖业务的任何增长。
我目前的数据集是这样的，我有几次重复交付（不同的货物/重量等，但相同的交货地点）。我想将这些＆＃34;重复＆＃34; /类似的行合并到列表中的单个条目中，总计交付的件数，重量和交付成本，并增加一个计数器以显示重复交付的数量各自的网站。
Example: January, 2016
Delivered from: Delivered to: No. Pieces: Weight: Cost:
Site A Site B 10 100 $120.00
Site A Site C 5 20 $80.00
Site B Site C 2 30 $45.00
Site A Site C 20 460 $375.00
Summary:
Delivered to: No. of Deliveries: No. Pieces: Weight: Cost:
Site B 1 10 100 $120.00
Site C 3 27 510 $500.00
我可以想办法将数据转储到＆＃34;废料＆＃34;但是，工作表，我想要一个VBA解决方案，它是＆＃34;内部＆＃34;所以没有这样的＆＃34;刮刮垫＆＃34;是必需的。
交货数量总计是动态的。 对于任何给定的位置，重复交付的数量也是动态的。
我发现使用上述参数组合一种有效的方法来合并列表中的信息是非常困难的，因为我对VBA / Excel还是一个新手。
任何建议都值得赞赏，特别是如果你有示例代码 - 我知道我想要什么，我只是不确定如何在VBA中实现它。
我的数组加载和传输到列表的示例如下所示（省略了变量定义等）。
Set List = CreateObject("System.Collections.SortedList")
'Grab Monthly Data by Route
For Each ws In Worksheets
If ws.Name <> "Summary" Then
Call DeleteHidden 'Delete Hidden Rows/Columns in the active worksheet if any
With ws
'loop through the sheet to 207 (~3x greatest number of deliveries)
For RowCount = 7 To 207
'Check for dates for each row (Month/Day/Year)
d = DateValue(.Cells(RowCount, 1))
If List.Containskey(d) Then
arTemp = List(d)
Else
ReDim arTemp(12)
End If
'Monthly Totals
arTemp(0) = arTemp(0) + .Cells(RowCount, 1) 'Grab Entry Date/Time
arTemp(1) = arTemp(1) + .Cells(RowCount, 2) 'Grab Delivery Date/Time
arTemp(2) = arTemp(2) + .Cells(RowCount, 3) 'Grab PU Location
arTemp(3) = arTemp(3) + .Cells(RowCount, 4) 'Grab PU Street
arTemp(4) = arTemp(4) + .Cells(RowCount, 5) 'Grab PU City/Province/PC
arTemp(5) = arTemp(5) + .Cells(RowCount, 6) 'Grab Del Location
arTemp(6) = arTemp(6) + .Cells(RowCount, 7) 'Grab Del Street
arTemp(7) = arTemp(7) + .Cells(RowCount, 8) 'Grab Del City/Province/PC
arTemp(8) = arTemp(8) + .Cells(RowCount, 9) 'Grab No. Pieces
arTemp(9) = arTemp(9) + .Cells(RowCount, 10) 'Grab Cargo Weight (LBS)
arTemp(10) = arTemp(10) + .Cells(RowCount, 11) 'Grab Cost
'potential add point of a sort and consolidate function if working with the array prior to data being added to the list (but then such would run for each record of each worksheet---seems too inefficient)
arTemp(12) = arTemp(12) + 1
List(d) = arTemp
Next RowCount
Call QuickSort(arTemp, 0, RowCount - 1) 'Sort the Monthly Array at the end of the Month (can manipulate the array but the list is already loaded..how to manipulate/consolidate the list???)
End With
End If
Next
答案 0 :(得分：3)
使用ADO，可以将Excel工作簿视为数据库，并针对它发出SQL语句。
（我在字段名称中遇到句点问题，因此我在原始数据中将No. Pieces更改为Number of Pieces。感谢@ThomasInzina。）
SELECT [Delivered to:],
COUNT(*) AS NumberOfDeliveries,
SUM([Number of Pieces:]) AS NumberOfPieces,
SUM([Weight:]) AS SumOfWeight,
SUM([Cost:]) AS SumOfCost
FROM [January, 2016$]
GROUP BY [Delivered to:]
第一步是使用ADO连接获取工作表名称列表。
然后，您可以遍历名称并发出SQL语句。数据以Recordset对象的形式返回，可以使用CopyRecordset方法轻松粘贴到Excel工作表中。
如果输出将是另一个工作簿，则可以在整个For Each期间保持输出工作簿处于打开状态，不断为每个月创建新工作表，并调用CopyFromRecordset在For Each的每次迭代中。但是，当同时通过Automation和ADO连接访问同一工作簿时，CopyFromRecordset似乎什么都不做。
因此，我们对每个工作表使用disconnected recordsets - 即使在收集关闭后，也会将所有数据存储在内存中;并使用Scripting.Dictionary保存对它们的引用，其中每个键是最终的工作表名称，值是断开连接的记录集。
这意味着所有最终数据都存储在内存中，这可能是一个问题。可能的解决方法是创建一个新的输出工作簿来保存粘贴的记录集数据，并在完成所有迭代并关闭连接后，将工作表从输出工作簿粘贴到原始工作簿中并删除输出工作簿。但是，您已在问题中表明您不想这样做。
将参考文献（工具 - ＆gt;参考文献... ）添加到 Microsoft ActiveX数据对象（选择最新版本;通常为6.1），然后 Microsoft脚本运行时。
Dim pathToWorkbook As String
pathToWorkbook = "C:\path\to\workbook.xlsx"
Dim conn As New ADODB.Connection
Dim schema As ADODB.Recordset
Dim sheetname As Variant
Dim sql As String
Dim rs As ADODB.Recordset
Dim dict As New Scripting.Dictionary
With conn
.Provider = "Microsoft.ACE.OLEDB.12.0"
.ConnectionString = "Data Source=""" & pathToWorkbook & """;" & _
"Extended Properties=""Excel 12.0;HDR=Yes"""
.Open
Set schema = .OpenSchema(adSchemaTables)
For Each sheetname In schema.GetRows(, , "TABLE_NAME") 'returns a 2D array of one column
If Not sheetname Like "*(Summary)*" Then
sql = _
"SELECT [Delivered to:], " & _
"COUNT(*) AS NumberOfDeliveries, " & _
"SUM([Number Of Pieces:]) AS SumNumberOfPieces, " & _
"SUM([Weight:]) AS SumOfWeight, " & _
"SUM([Cost:]) AS SumOfCost " & _
"FROM [" & sheetname & "] " & _
"GROUP BY [Delivered to:]"
Set rs = New ADODB.Recordset
rs.CursorLocation = adUseClient 'This defines a disconnected recordset
rs.Open sql, conn, adOpenStatic, adLockBatchOptimistic 'Disconnected recordsets require these options
Set rs.ActiveConnection = Nothing 'Recordset disconnected
sheetname = Mid(sheetname, 2, Len(sheetname) - 3)
dict.Add sheetname & " (Summary)", rs
End If
Next
.Close
End With
Dim xlApp As New Excel.Application
xlApp.Visible = True
xlApp.UserControl = True
Dim wkbk As Excel.Workbook
Dim wks As Excel.Worksheet
Dim key As Variant
Set wkbk = xlApp.Workbooks.Open(pathToWorkbook)
For Each key In dict.Keys
Set wks = wkbk.Sheets.Add
wks.Name = key
wks.Range("A1").CopyFromRecordset dict(key)
Next
<强>链接：
MSDN：
其他：
答案 1 :(得分：1)
我在摘要中添加了一个月的专栏。
Sub Summary()
Dim ws As Worksheet
Dim iMonth As Integer, x As Long, x1 As Long
Dim Data, key
Dim list(1 To 12) As Object
For x = 1 To 12
Set list(x) = CreateObject("System.Collections.SortedList")
Next
For Each ws In Worksheets
If ws.Name <> "Summary" Then
Call DeleteHidden 'Delete Hidden Rows/Columns in the active worksheet if any
With ws
For x = 1 To 207
If IsDate(.Cells(x, 1)) Then
iMonth = Month(.Cells(x, 1))
key = .Cells(x, 6) 'Grab Del Location
If list(iMonth).ContainsKey(key) Then
Data = list(iMonth)(key)
Else
ReDim Data(5)
Data(0) = iMonth
Data(1) = .Cells(x, 6) 'Grab Del Location
End If
Data(2) = Data(2) + 1
Data(3) = Data(3) + .Cells(x, 9) 'Grab No. Pieces
Data(4) = Data(4) + .Cells(x, 10) 'Grab Cargo Weight (LBS)
Data(5) = Data(5) + .Cells(x, 11) 'Grab Cost
list(iMonth)(key) = Data
End If
Next
End With
End If
Next
With Worksheets("Summary")
For x = 1 To 12
For x1 = 0 To list(x).Count - 1
.Range("A" & .Rows.Count).End(xlUp).Offset(1).Resize(1, 6).Value = list(x).GetByIndex(x1)
Next
Next
End With
End Sub
答案 2 :(得分：1)
以下是将示例数据聚合到2D数组中的较短的lazier版本，但它假定A6:E6具有与示例中相同的标题名称：
Dim arr(), rs As Object: Set rs = CreateObject("ADODB.Recordset")
rs.Open "Select [Delivered to:], Count(*), Sum([No# Pieces:]), " & _
"Sum([Weight:]), Format(Sum([Cost:]),'$0.00') " & _
"From ( SELECT * From [January$A6:E207] Union All " & _
" SELECT * From [February$A6:E207] ) " & _
"Where [Delivered to:] > '' Group By [Delivered to:]", _
"Provider=MSDASQL;DSN=Excel Files;DBQ=" & ThisWorkbook.FullName
If Not rs.EOF Then arr = rs.GetRows ': For Each i In arr: Debug.Print i & " ";: Next
rs.Close: Set rs = Nothing
如果没有标题单元格，则此替代版本需要安装ACE提供程序（Access 2007及更高版本附带，或者可以单独下载和安装）
rs.Open "Select F2, Count(*), Sum(F3), Sum(F4), Format(Sum(F5),'Currency') " & _
"From ( SELECT * From [January$A6:E207] Union All " & _
" SELECT * From [February$A6:E207] ) Where F2 > '' Group By F2", _
"Provider=Microsoft.ACE.OLEDB.12.0;Extended Properties='Excel 12.0;HDR=No';Data Source=" & ThisWorkbook.FullName ' ODBC Provider in case no ACE Provider