CODEWITHSUNDEEP
excelvba
katipra
katipra

Reputation: 55

vba-sum and group by without using sql-adodb

I have the following data in 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  |
|      |       |       |    |
+------+-------+-------+----+

I don't need the rows which start with DGPS,PART or is null.So I have to remove them. Then I need to perform sum and group by. First I need to convert net to -net if CD = D. Then try to get name,sum(count),sum(net) group by name. Then finally perform a check on if sum(net) > 0 then CD=C and if sum(net)<0 then CD=D.

I could use the following query in 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);

But I am not allowed to use external DB or lib, so cannot use sql-adodb. But I am hopeful that since this is a simple sum and group by ,we can achieve it by only vba without using sql.

EDIT: SAMPLE FINAL OUTPUT format

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

Upvotes: 2

Views: 1623

Answers (3)

VBasic2008
VBasic2008

Reputation: 54807

Magic Sort

  • The code is written to create the Target Worksheet ("Result") in ThisWorkbook i.e. the workbook that contains this code.
  • Carefully adjust the values in the constants (Const) section.
  • Added CSV Enabler. If you want to copy the data from CSV you have to set cEnableCSV to True and change cCsv to the name of the open CSV file including the extension e.g. "Sum Group.csv".
  • If you run into trouble with CSV, check out my post CSV Nightmare.
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

Upvotes: 0

Parfait
Parfait

Reputation: 107652

Consider using SQL if using Excel for Windows. Below shows connection strings with driver using ODBC and provider using OLEDB. However, your current SQL which looks to be Oracle dialect must be translated to the Jet/ACE SQL dialect (very engine of MS Access). Also, below assumes your data maintains headers and begins in top leftmost cell at A1 and blank worksheet named RESULTS for query output.

SQL (used in VBA string further below, adjust SheetName in 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 (no loops or if logic)

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

Upvotes: 1

Pᴇʜ
Pᴇʜ

Reputation: 57683

Probably something like that:

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

Upvotes: 2

Related Questions