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

Question

I have an array which stores it\'s values in a sorted list. I have been using this sorted list to organise data, by date in several other spreadsheets.

My source dat

Answer 1

Here is shorter lazier version that will aggregate the example data into a 2D array, but it assumes that A6:E6 has the same header names as in your example:

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

If there are no header cells, this alternative version needs the ACE Provider to be installed (comes with Access 2007 and above, or can be downloaded and installed separately)

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

Answer 2

Using ADO, it is possible to treat an Excel workbook as a database, and issue SQL statements against it.

(I had trouble with periods in the field name, so I changed No. Pieces to Number of Pieces in the original data. Thanks @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:]

The first step would be to get a list of worksheet names, using the ADO connection.

Then you can iterate over the names and issue the SQL statement. Data comes back as a Recordset object, which can easily be pasted into an Excel worksheet using the CopyRecordset method.

If the output would be to a different workbook, then it would be possible to keep the output workbook open during the whole of the For Each, continuously create new worksheets for each month, and call CopyFromRecordset at each iteration of the For Each. However, when accessing the same workbook via Automation and the ADO connection simultaneously, CopyFromRecordset seemed to do nothing.

Therefore, we're using disconnected recordsets for each worksheet — that store all the data in memory even after the collection is closed; and holding references to them using a Scripting.Dictionary, where each key is the final worksheet name, and the value is the disconnected recordset.

^{This means that all the final data is stored in memory, which could conceivably be an issue. A possible workaround would be to create a new output workbook to hold the pasted recordset data, and when all the iterations are finished and the connection is closed, to paste the worksheets from the output workbook into the original workbook and delete the output workbook. However, you've indicated in the question that you don't want to do this.}

Add references (Tools -> References ...) to Microsoft ActiveX Data Objects (choose the latest version; it's usually 6.1), and Microsoft Scripting Runtime.

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

---

Links:

MSDN:

• ADO — Connection and Recordset objects
• How to create disconnected recordsets
• VBA
• Scripting.Dictionary
• Excel automation

Other:

• Using disconnected recordsets

Answer 3

I added a month column in the summary.

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