Как объединить похожие записи в отсортированном списке без вывода на лист с помощью VBA/Excel

У меня есть массив, который хранит его значения в отсортированном списке. Я использовал этот отсортированный список для организации данных по дате в нескольких других электронных таблицах.

Мои исходные данные - это серия из 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")

    '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
Источник

3 ответа

Решение

Я добавил столбец месяца в резюме.

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
Источник

Используя 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 объект, который может быть легко вставлен в лист Excel с помощью CopyRecordset метод.

Если выходные данные будут относиться к другой рабочей книге, то можно было бы сохранить рабочую книгу открытой в течение всей рабочей книги. For Each непрерывно создавайте новые рабочие листы на каждый месяц и звоните CopyFromRecordset на каждой итерации For Each, Однако при одновременном доступе к одной и той же книге через автоматизацию и соединение ADO CopyFromRecordset казалось, ничего не делал.

Поэтому мы используем отключенные наборы записей для каждого рабочего листа, которые хранят все данные в памяти даже после закрытия коллекции; и хранение ссылок на них с использованием Scripting.Dictionary, где каждый ключ - это конечное имя рабочего листа, а значение - отключенный набор записей.

Это означает, что все окончательные данные хранятся в памяти, что может быть проблемой. Возможный обходной путь - создать новую выходную рабочую книгу для хранения вставленных данных набора записей, а после завершения всех итераций и закрытия подключения вставить рабочие листы из выходной рабочей книги в исходную рабочую книгу и удалить выходную рабочую книгу. Однако в вопросе вы указали, что не хотите этого делать.

Добавьте ссылки (Инструменты -> Ссылки...) к объектам данных Microsoft ActiveX (выберите последнюю версию; обычно это 6.1) и 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

Ссылки:

MSDN:

Другой:

Источник

Вот более короткая более ленивая версия, которая объединит данные примера в двумерный массив, но предполагает, что 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
Источник
Другие вопросы по тегам