vba-сумма и группировка без использования sql-adodb

Question

У меня есть следующие данные в Excel:

+------+-------+-------+----+
| name | count | net   | CD |
+------+-------+-------+----+
| c1   | 125   | 12500 | D  |
| c2   | 55    | 3500  | C  |
| c3   | 80    | 2599  | C  |
| c4   | 30    | 1500  | D  |
| DGPS | 45    | 1000  | D  |
|      |       |       |    |
| PART | 51    | 1560  | C  |
| DGPS | 20    | 1990  | D  |
| c2   | 25    | 1325  | C  |
|      |       |       |    |
| c3   | 15    | 4500  | C  |
| c1   | 25    | 6300  | D  |
|      |       |       |    |
+------+-------+-------+----+

Мне не нужны строки, которые начинаются с DGPS, PART или имеют значение null. Поэтому я должен удалить их.Тогда мне нужно выполнить сумму и группировать по.Сначала мне нужно преобразовать net в -net, если CD = D. Затем попытаться получить имя, сумму (количество), сумму (сеть) по имени.Затем, наконец, выполните проверку, если сумма (нетто)> 0, тогда CD = C, а если сумма (нетто) <0, то CD = D. </p>

Я мог бы использовать следующий запрос в sql:

select name,sum(count),to_char(ABS(ROUND(sum(net),2))),CASE when sum(net) > 0 then 'C' when sum(net) < 0 then 'D' when sum(net) = 0 then '0' END AS CD
FROM
(SELECT name,count,CASE WHEN CD = 'C' THEN to_char(ROUND(net,2)) ELSE to_char(ROUND(-net,2)) END AS net
FROM tb1 
)
group by name order by upper(name);

Но мне не разрешено использовать внешнюю БД или lib, поэтому я не могу использовать sql-adodb.Но я надеюсь, что, поскольку это простая сумма и группировка, мы можем достичь ее только с помощью vba без использования sql.

РЕДАКТИРОВАТЬ: ОБРАЗЕЦ ФИНАЛЬНОГО ВЫХОДА

+------+-------+-------+----+
| name | count | net   | CD |
+------+-------+-------+----+
| c1   | 150   | 18800 | D  |
| c2   | 80    | 4825  | C  |
| c3   | 95    | 7099  | C  |
| c4   | 30    | 1500  | D  |
+------+-------+-------+----+

Answer 1

Возможно что-то в этом роде:

Option Explicit

Public Sub SpecialSum()
    Dim wsData As Worksheet
    Set wsData = ThisWorkbook.Worksheets("data")

    Dim wsOutput As Worksheet
    Set wsOutput = ThisWorkbook.Worksheets("output")

    Dim AllNames As Variant
    AllNames = wsData.Range("A2", wsData.Cells(wsData.Rows.Count, "A").End(xlUp)).Value

    Dim UniqueNames As Object
    Set UniqueNames = CreateObject("Scripting.Dictionary")

    Dim iRow As Long
    For iRow = 1 To UBound(AllNames, 1)
        If AllNames(iRow, 1) <> "DGPS" And AllNames(iRow, 1) <> "PART" And AllNames(iRow, 1) <> "" Then
            If Not UniqueNames.Exists(AllNames(iRow, 1)) Then
                UniqueNames.Add AllNames(iRow, 1), 1
            End If
        End If
    Next iRow

    ReDim AllNames(1 To UniqueNames.Count, 1 To 1) As String
    iRow = 1
    Dim Key As Variant
    For Each Key In UniqueNames.Keys
        AllNames(iRow, 1) = Key
        iRow = iRow + 1
    Next Key

    wsOutput.Rows(1).Value = wsData.Rows(1).Value
    wsOutput.Range("A2").Resize(RowSize:=UniqueNames.Count).Value = AllNames
    wsOutput.Range("B2").Resize(RowSize:=UniqueNames.Count).Formula = "=SUMIF('" & wsData.Name & "'!A:A,'" & wsOutput.Name & "'!A:A,'" & wsData.Name & "'!B:B)"
    wsOutput.Range("C2").Resize(RowSize:=UniqueNames.Count).Formula = "=ABS(SUMIFS('" & wsData.Name & "'!C:C,'" & wsData.Name & "'!A:A,""=""&A2,'" & wsData.Name & "'!D:D,""=C"")-SUMIFS(data!C:C,'" & wsData.Name & "'!A:A,""=""&A2,'" & wsData.Name & "'!D:D,""=D""))"
    wsOutput.Range("D2").Resize(RowSize:=UniqueNames.Count).Formula = "=IF(SUMIFS('" & wsData.Name & "'!C:C,'" & wsData.Name & "'!A:A,""=""&A2,'" & wsData.Name & "'!D:D,""=C"")-SUMIFS(data!C:C,'" & wsData.Name & "'!A:A,""=""&A2,'" & wsData.Name & "'!D:D,""=D"")<0,""D"", ""C"")"
End Sub

Answer 2

Рассмотрите возможность использования SQL при использовании Excel для Windows.Ниже показаны строки подключения с драйвером, использующим ODBC, и провайдер, использующий OLEDB.Однако ваш текущий SQL, который выглядит как диалект Oracle, должен быть переведен на диалект SQL Jet / ACE (очень движок MS Access).Кроме того, ниже предполагается, что ваши данные поддерживают заголовки и начинаются в самой верхней левой ячейке в A1 и на пустом листе с именем РЕЗУЛЬТАТЫ для вывода запроса.

SQL (используется вНиже приведена строка VBA, настройте SheetName в FROM)

SELECT agg.[name], 
       agg.sum_count AS [count], 
       agg.sum_net AS [net],
       IIF(sub.sum_net > 0, 'C', 
           IIF(sub.sum_net < 0, 'D', '0')
          ) AS [CD]
FROM
  (SELECT s.[name], 
          SUM(s.[count]) AS sum_count,
          SUM(IIF(CD = 'C', ROUND(net,2), ROUND(net,2) * -1)) AS sum_net
   FROM [SheetName$] s
   WHERE INSTR(s.[name], 'DGPS') = 0 OR INSTR(s.[name], 'PART') = 0
   GROUP BY s.[name]
 ) AS agg

ORDER BY UCASE(agg.[name]);

VBA (без циклов или с логикой)

Sub RunSQL() 
   Dim conn As Object, rst As Object 
   Dim strConnection As String, strSQL As String
   Dim LastRow As Integer

   Set conn = CreateObject("ADODB.Connection") 
   Set rst = CreateObject("ADODB.Recordset")

   ' TWO CONNECTION STRINGS FOR DRIVER OR PROVIDER
   ' strConnection = "DRIVER={Microsoft Excel Driver (*.xls, *.xlsx, *.xlsm, *.xlsb)};" _ 
   '                  & "DBQ=" & ThisWorkbook.FullName & ";" 
   strConnection = "Provider=Microsoft.ACE.OLEDB.12.0;" _ 
                    & "Data Source='" & ThisWorkbook.FullName & "';" _ 
                    & "Extended Properties=""Excel 12.0;HDR=YES;"";"

   ' OPEN DB CONNECTION 
   conn.Open strConnection

   ' OPEN QUERY RECORDSET 
   strSQL = "SELECT agg.[name], " _
            & "     agg.sum_count AS [count],  " _
            & "     agg.sum_net AS [net], " _
            & "     IIF(sub.sum_net > 0, 'C',  " _
            & "         IIF(sub.sum_net < 0, 'D', '0')  " _
            & "         ) AS [CD]  " _
            & " FROM  " _
            & "     (SELECT s.[name],  " _
            & "             SUM(s.[count]) AS sum_count,  " _
            & "             SUM(IIF(CD = 'C', ROUND(net,2), ROUND(net,2) * -1)) AS sum_net  " _
            & "      FROM [SheetName$] s  " _
            & "      WHERE INSTR(s.[name], 'DGPS') = 0 OR INSTR(s.[name], 'PART') = 0  " _
            & "      GROUP BY s.[name]  " _
            & "    ) AS agg  " _
            & "   ORDER BY UCASE(agg.[name]);"

   rst.Open strSQL, conn

   ' COPY DATA TO WORKSHEET 
   Worksheets("RESULTS").Range("A2").CopyFromRecordset rst 

   rst.Close: conn.Close
   Set rst = Nothing: Set conn = Nothing
End Sub

Answer 3

Волшебная сортировка

• Код написан для создания Target Worksheet ("Result") в ThisWorkbook то есть в рабочей книге, содержащей этот код.
• Тщательно отрегулируйте значения в разделе констант (Const).
• Добавлено CSV Enabler . Если вы хотите скопировать данные из CSV, вы необходимо установить cEnableCSV на True и изменить cCsv на имя файл open CSV, включая расширение, например, « Сумма Group.csv ».
• Если у вас возникли проблемы с CSV, посмотрите мой пост CSV Кошмар .

Option Explicit

Sub MagicSort()

    ' Note: Do not remove the first comma, because it will include "" into
    ' the array.
    Const cExceptions As String = ",DGPS,PART" ' Exception List
    Const cSheet As String = "Sheet1"         ' Source Worksheet Name
    Const cTarget As String = "Result"        ' Target Worksheet Name
    Const cCols As String = "A:D"             ' Source Columns Range Address
    Const cHeaders As Long = 1                ' Source Header Row Number
    Const cFcell As String = "A1"             ' Target First Cell Address
    ' CSV
    Const cCsv As String = "Sum Group.csv"    ' Source CSV Name
    Const cEnableCSV As Boolean = False       ' CSV Enabler, True: enable CSV.

    Dim wsT As Worksheet  ' Target Worksheet
    Dim rng As Range      ' Init Last Used Cell Range,
                          ' Init Range
    Dim dict As Object    ' Source Dictionary
    Dim key As Variant    ' Dictionary Key
    Dim vntI As Variant   ' Init Array
    Dim vntE As Variant   ' Exception Array
    Dim vntS As Variant   ' Source Array
    Dim NorI As Long      ' Init Number of Rows
    Dim Noe As Long       ' Number of Exceptions - 1 (0-based array)
    Dim NorS As Long      ' Source Number of Rows
    Dim NorT As Long      ' Target Number of Rows
    Dim Noc As Long       ' (Init/Source) Number of Columns
    Dim i As Long         ' Init Row Counter
    Dim j As Long         ' Column Counter
    Dim k As Long         ' Source Row Counter
    Dim m As Long         ' Exception Element Counter
    Dim currV As Variant  ' Current Value (in 1st, 2nd Column)

    ' Task: Copy all data sorted to Init Array.

    With ThisWorkbook
        ' Delete Target Worksheet if it exists.
        Application.DisplayAlerts = False
        On Error Resume Next
        .Worksheets(cTarget).Delete
        On Error GoTo 0
        Application.DisplayAlerts = True
        ' Check value of CSVEnabler.
        If cEnableCSV Then
            ' Create a copy of Source CSV as Target Worksheet.
            Windows(cCsv).ActiveSheet.Copy After:=.Worksheets(.Sheets.Count)
          Else
            ' Create a copy of Source Worksheet as Target Worksheet.
            .Worksheets(cSheet).Copy After:=.Worksheets(.Sheets.Count)
        End If
        ' Create a reference to Target Worksheet.
        Set wsT = ActiveSheet
        ' Rename Target Worksheet.
        wsT.Name = cTarget
    End With

    ' In Target Worksheet
    With wsT.Columns(cCols)
        ' Calculate and create a reference to Source Last Used Cell Range.
        Set rng = .Resize(, 1).Find("*", , xlFormulas, , , xlPrevious)
        ' Calculate and create a reference to Init Range.
        Set rng = .Rows(cHeaders).Resize(rng.Row - cHeaders + 1)
        ' Sort Init Range.
        rng.Sort Key1:=Range("A2"), Order1:=xlAscending, Header:=xlYes
    End With

    ' Write number of rows in Init Range to Init Number of Rows.
    NorI = rng.Rows.Count
    ' Write number of columns in Init Range to Number of Columns.
    Noc = rng.Columns.Count
    ' Copy Init Range to Init Array.
    vntI = rng

    ' Task: Count Source Number of Rows.

    ' Write Exception List to Exception Array.
    vntE = Split(cExceptions, ",")
    ' Write number of elements in Exception Array to Number of Exceptions - 1.
    Noe = UBound(vntE)
    ' Loop through rows in 1st column of Init Array.
    For i = 1 To NorI
        ' Write current element of Init Array to Current Value.
        currV = Trim(vntI(i, 1))
        ' Loop through elements of Exception Array.
        For m = 0 To Noe
            ' Check if value of current element in Init Array is different
            ' than value of current element in Exception Array.
            If currV = vntE(m) Then Exit For
        Next
        ' Check if match was not found.
        If m = Noe + 1 Then
            ' Count Source Row.
            k = k + 1
        End If
    Next
    ' Write current value of Source Row Counter to Source Number of Rows.
    NorS = k

    ' Task: Write 'cleaned' data to Source Array.

    ' Resize Source Array to Source Number of Rows by Number of Columns.
    ReDim vntS(1 To NorS, 1 To Noc)
    ' Reset Source Row Counter
    k = 0
    ' Loop through rows of Init Array.
    For i = 1 To NorI
        ' Write current element of Init Array to Current Value.
        currV = Trim(vntI(i, 1))
        ' Loop through elements of Exception Array.
        For m = 0 To Noe
            ' Check if value of current element in Init Array is different
            ' than value of current element in Exception Array.
            If currV = vntE(m) Then Exit For
        Next
        ' Check if match was not found.
        If m = Noe + 1 Then
            ' Count Source Row.
            k = k + 1
            ' Loop through columns (of Init/Source Array).
            For j = 1 To Noc
                ' Write current value from Init Array to current element
                ' of Source Array.
                vntS(k, j) = vntI(i, j)
            Next
        End If
    Next
    ' Erase not needed arrays.
    Erase vntI
    Erase vntE

    ' Task: Perform calculations and write to Target Array.

    For k = 1 To NorS
        If Trim(vntS(k, 4)) = "D" Then vntS(k, 3) = -vntS(k, 3)
    Next

    ' Create a reference to Source Dictionary.
    Set dict = CreateObject("Scripting.Dictionary")
   ' Loop through elements (rows) of Source Array.
    For k = 2 To NorS
        ' Write element in current row (i) in 2nd column of Source Array (vntS)
        ' to Current Value.
        currV = vntS(k, 2)
        ' Check if Current Value (CurV) is NOT a number.
        If Not IsNumeric(currV) Then
            ' Assign 0 to Current Value.
            currV = 0
        End If
        ' Add current element (row) in Source Array (vntS) and Current Value
        ' to the Dictionary. If the key to be added is new (not existing),
        ' the new key and the item will be added. But if the key exists, then
        ' the existing item will be increased by the value of the new item.
        ' This could be called "The Dictionary SumIf Feature".
        dict(vntS(k, 1)) = dict(vntS(k, 1)) + currV
    Next

    ' Write Number of keys in Source Dictionary + 1 for Headers to Target
    ' Number of Rows.
    NorT = dict.Count + 1 ' + 1 for headers.

    ' Resize Target Array to Target Number of Rows and Number of Columns.
    ReDim vntT(1 To NorT, 1 To Noc)

    ' Write Headers from Source to Target Array's first row.
    For j = 1 To Noc
        vntT(1, j) = vntS(1, j)
    Next

    ' Reset Dictionary (Row) Counter.
    i = 1
    For Each key In dict.Keys
        ' Count Dictionary Key.
        i = i + 1
        ' Write Dictionary Key to 1st column Target Array.
        vntT(i, 1) = key
        ' Write Dictionary Value to 2nd column Target Array.
        vntT(i, 2) = dict(key)
    Next

    ' Clear Source Dictionary.
    dict.RemoveAll

   ' Loop through elements (rows) of Source Array.
    For k = 2 To NorS
        ' Write element in current row (i) in 2nd column of Source Array (vntS)
        ' to Current Value.
        currV = vntS(k, 3)
        ' Check if Current Value (CurV) is NOT a number.
        If Not IsNumeric(currV) Then
            ' Assign 0 to Current Value.
            currV = 0
        End If
        ' Add current element (row) in Source Array (vntS) and Current Value
        ' to the Dictionary. If the key to be added is new (not existing),
        ' the new key and the item will be added. But if the key exists, then
        ' the existing item will be increased by the value of the new item.
        ' This could be called "The Dictionary SumIf Feature".
        dict(vntS(k, 1)) = dict(vntS(k, 1)) + currV
    Next

    ' Erase not needed arrays.
    Erase vntS

    ' Reset Dictionary (Row) Counter.
    i = 1
    For Each key In dict.Keys
        ' Count Dictionary Key.
        i = i + 1
        ' Write Dictionary Key to 1st column Target Array.
        vntT(i, 1) = key
        ' Write Dictionary Value to 2nd column Target Array.
        vntT(i, 3) = dict(key)
    Next

    ' Clear Source Dictionary.
    dict.RemoveAll

    ' Calculate 3rd and 4th column.
    For k = 2 To NorT
        If vntT(k, 3) > 0 Then
            vntT(k, 4) = "C"
          Else
            vntT(k, 4) = "D"
            vntT(k, 3) = -vntT(k, 3)
        End If
    Next

'    For j = 1 To Noc
'        For i = 1 To NorT
'            Debug.Print vntT(i, j)
'        Next
'    Next

    With ThisWorkbook.Worksheets(cTarget)
        .Cells.ClearContents
        Set rng = .Range(cFcell).Resize(NorT, Noc)
    End With

    rng.Value = vntT

    ' Apply Formatting
    With rng
        ' Apply formatting to whole Target Range.
        .Columns.AutoFit

'        ' Apply formatting to Headers only:
'        With .Rows(1)
'
'        End With
'        ' Apply formatting to Body (Data) only:
'        With .Rows(1).Offset(1).Resize(Rows.Count - 1)
'
'        End With

    End With

End Sub