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

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

vba excel sorting

如何使用VBA/Excel合并排序列表中的类似条目而不输出到工作表,vba,excel,sorting,Vba,Excel,Sorting,我有一个数组，它将它的值存储在一个排序列表中。我一直在使用这个排序列表在其他几个电子表格中按日期组织数据我的源数据是一个工作簿中12个工作表的系列。每个工作表反映一个日历月。事务/运行的数量是动态的——平均每月60次左右，因此我将循环限制为200次，因为这应该足以覆盖业务的任何增长我目前的数据集是这样的，我有几个重复交付（不同的货物/重量等，但相同的交付位置）。我想将这些“重复”/“类似”行合并到列表中的单个条目中，将交付的件数、重量和交付成本相加，并增加一个计数器以显示到相应站点的重复交付

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

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

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

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中实现它

下面显示了我的数组加载和传输到列表的示例（省略了变量定义等）

Set List=CreateObject（“System.Collections.SortedList”）
'按路线获取每月数据
对于工作表中的每个ws
如果ws.Name是“Summary”，那么
调用DeleteHidden“删除活动工作表中的隐藏行/列（如果有）”
与ws
'将表格循环到207页（~3倍的最大交付次数）
对于RowCount=7到207
'检查每行的日期（月/日/年）
d=日期值（.Cells（行数，1））
如果列表中包含（d），则
arTemp=列表（d）
其他的
雷迪姆·阿滕普（12）
如果结束
"月总数",
arTemp（0）=arTemp（0）+.单元格（行数，1）'抓取输入日期/时间
arTemp（1）=arTemp（1）+.单元格（行数，2）'抓取交货日期/时间
arTemp（2）=arTemp（2）+.单元格（行数，3）'抓取PU位置
arTemp（3）=arTemp（3）+单元格（行数，4）'Grab PU Street
arTemp（4）=arTemp（4）+单元格（行数，5）'Grab PU市/省/PC
arTemp（5）=arTemp（5）+.单元格（行数，6）'抓取删除位置
arTemp（6）=arTemp（6）+单元格（行数，7）'Grab Del Street
arTemp（7）=arTemp（7）+单元格（行数，8）'Grab Del City/Province/PC
arTemp（8）=arTemp（8）+.单元格（行数，9）'抓取件数
arTemp（9）=arTemp（9）+单元格（行数，10）'抓取货物重量（磅）
arTemp（10）=arTemp（10）+单元格（行数，11）“抓取成本
'如果在将数据添加到列表之前使用数组，则排序和合并函数的潜在添加点（但这样会对每个工作表的每条记录运行，似乎效率太低）
arTemp（12）=arTemp（12）+1
列表（d）=arTemp
下一行计数
调用快速排序（arTemp，0，RowCount-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

子摘要（）
将ws设置为工作表
Dim iMonth为整数，x为长，x1为长
Dim数据，键
作为对象的尺寸列表（1到12）
对于x=1到12
集合列表（x）=CreateObject（“System.Collections.SortedList”）
下一个
对于工作表中的每个ws
如果ws.Name是“Summary”，那么
调用DeleteHidden“删除活动工作表中的隐藏行/列（如果有）”
与ws
对于x=1到207
如果是IsDate（.Cells（x，1）），则
iMonth=Month（.Cells（x，1））
键=.Cells（x，6）'Grab Del位置
如果列表（iMonth）.ContainsKey（key）那么
数据=列表（iMonth）（键）
其他的
重拨数据（5）
数据（0）=iMonth
数据（1）=.单元格（x，6）“抓取删除位置”
如果结束
数据（2）=数据（2）+1
数据（3）=数据（3）+单元（x，9）'抓取件数量
数据（4）=数据（4）+单元格（x，10）'抓取货物重量（磅）
数据（5）=数据（5）+单元格（x，11）“抓取成本”
列表（iMonth）（键）=数据
如果结束
下一个
以
如果结束
下一个
带工作表（“摘要”）
对于x=1到12
对于x1=0的列表（x）。计数-1
.Range（“A”和.Rows.Count）.End（xlUp）.Offset（1）.Resize（1,6）.Value=list（x）.GetByIndex（x1）
下一个
下一个
以
端接头

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

（我对字段名中的句点有问题，因此我将原始数据中的

No.Pieces

更改为

Number of Pieces

。谢谢@ThomasInzina。）

第一步是使用ADO连接获取工作表名称列表

然后可以迭代这些名称并发出SQL语句。数据作为

记录集

对象返回，可以很容易地粘贴到int中

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

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:]

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

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

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