如何合并排序列表中的类似条目而不使用VBA / Excel输出到工作表


How to consolidate similar entries in a sorted list without output to a worksheet using VBA/Excel

我有一个数组，它将它的值存储在一个排序列表中。我一直在使用这个排序的列表，在其他几个电子表格中按日期组织数据。

我的源数据是一个工作簿中12个工作表的系列。每个工作表反映一个日历月。事务/运行的数量是动态的——平均每月60个左右，所以我将循环限制为200个，因为这应该足以覆盖业务的任何增长。

我目前的数据集是这样的，我有几个重复交付(不同的货物/重量等。但交货地点相同)。我想将这些"重复"/类似的行合并到列表中的一个条目中，合计交付的件数、重量和交付成本，并增加一个计数器来显示到相应站点的重复交付的数量。

1
2
3
4
5
6
7
8
9
10
11
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

我可以通过将数据转储到"报废"工作表来考虑实现这一点的方法，但是，我需要一个"内部"的VBA解决方案，这样就不需要这样的"草稿板"。

交付总数是动态的。对于任何给定位置，重复交付的次数也是动态的。

我发现很难用上述参数组成一种有效的方法来合并列表中的信息，因为我对vba/excel还是个新手。

任何建议都会受到赞赏，特别是如果您有示例代码——我知道我想要什么，我只是不确定如何在VBA中实现它。

下面显示了我的数组加载和传输到列表的示例(使用变量定义等。省略)。

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
    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
相关讨论

使用ADO，可以将Excel工作簿视为数据库，并针对它发出SQL语句。

(我在字段名中的句点有问题，所以在原始数据中我将No. Pieces改为Number of Pieces。谢谢@thomasinzina。)

1
2
3
4
5
6
7
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期间保持输出工作簿打开，每个月连续创建新的工作表，并在For Each的每次迭代时调用CopyFromRecordset。然而，当通过自动化和ADO连接同时访问同一个工作簿时，CopyFromRecordset似乎什么也没做。

因此，我们正在为每个工作表使用断开连接的记录集&mdash；，这些记录集即使在集合关闭后也将所有数据存储在内存中；并使用scripting.dictionary保存对它们的引用，其中每个键都是最终工作表名称，值是断开连接的记录集。

这意味着所有最终数据都存储在内存中，这可能是一个问题。一个可能的解决方法是创建一个新的输出工作簿来保存粘贴的记录集数据，当所有迭代完成并且连接关闭时，将输出工作簿中的工作表粘贴到原始工作簿中并删除输出工作簿。但是，您在问题中表示不想这样做。

向Microsoft ActiveX数据对象(选择最新版本；通常为6.1)和Microsoft脚本运行时添加引用(工具->引用…)。

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
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:

  • ADO&mdash；连接和记录集对象
  • 如何创建断开连接的记录集
  • VBA
  • 脚本.dictionary
  • Excel自动化

其他：

  • 使用断开连接的记录集
相关讨论

下面是将示例数据聚合到二维数组中的较短的更惰性版本，但它假定A6:E6具有与示例中相同的头名称：

1
2
3
4
5
6
7
8
9
10
11
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及更高版本提供，或者可以单独下载和安装)

1
2
3
4
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
相关讨论

我在摘要中添加了一个月栏。

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
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
相关讨论