CODEWITHSUNDEEP
vbaexcel
Pablo Gûereca
Pablo Gûereca

Reputation: 725

sum and group vba sheet

I am finishing with a project and I have stocked with some templates that I need to group... the information looks like this:

enter image description here

and I need sum casedocs and call count columns to get something like this using VBA code:

enter image description here

I do not know how to make it possible...any suggestion?

Upvotes: 0

Views: 8170

Answers (3)

Pablo Gûereca
Pablo Gûereca

Reputation: 725

Sub consolidateData()

Dim lRow As Long
Dim ItemRow1, ItemRow2 As String
Dim lengthRow1, lengthRow2 As String

    lRow = 3
    Do While (Cells(lRow, 1) <> "")

        ItemRow1 = Cells(lRow, "A")
        ItemRow2 = Cells(lRow + 1, "A")

        lengthRow1 = Cells(lRow, "B")
        lengthRow2 = Cells(lRow + 1, "B")

        If ((ItemRow1 = ItemRow2) And (lengthRow1 = lengthRow2)) Then
            Cells(lRow, "D") = Cells(lRow, "D") + Cells(lRow + 1, "D")

            Cells(lRow, "E") = Cells(lRow, "E") + Cells(lRow + 1, "E")
            Rows(lRow + 1).Delete

        Else
            lRow = lRow + 1
        End If

    Loop
End Sub

Upvotes: 3

user6432984
user6432984

Reputation:

SQL is ideal for grouping and summing data. In this example I use an ADODB connection to group and sum the data.

enter image description here

Sub CreateConsolidatedTable()
    Const adOpenKeyset = 1
    Const adLockOptimistic = 3
    Const WORKSHEETNAME As String = "Sheet1"
    Const TABLENAME As String = "Table1"

    Dim conn As Object, rs As Object
    Dim tbl As ListObject
    Dim Destination As Range
    Set Destination = Worksheets.Add.Range("A1")

    Set tbl = Worksheets(WORKSHEETNAME).ListObjects(TABLENAME)

    Set conn = CreateObject("ADODB.Connection")
    conn.ConnectionString = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & ThisWorkbook.FullName & ";Extended Properties=""Excel 12.0;HDR=Yes;IMEX=1"";"

    conn.Open
    '  On Error GoTo CloseConnection
    Set rs = CreateObject("ADODB.Recordset")
    With rs
        .ActiveConnection = conn
        .CursorType = adOpenKeyset
        .LockType = adLockOptimistic
        .Source = getSQL(tbl)
        .Open

        With Destination
            tbl.HeaderRowRange.Copy .Range("A1")
            .Range("A2").CopyFromRecordset rs
            .Parent.ListObjects.Add SourceType:=xlSrcRange, Source:=.Range("A1").CurrentRegion, XlListObjectHasHeaders:=xlYes, TableStyleName:=tbl.TableStyle

        End With
    End With
CloseRecordset:
    rs.Close
    Set rs = Nothing
CloseConnection:
    conn.Close
    Set conn = Nothing
End Sub

Function getSQL(tbl As ListObject) As String
    Dim SQL As String, SheetName As String, RangeAddress As String
    SQL = "SELECT DISTINCTROW [LastName], [FirstName], [Agent ID], Sum([Case Docs]) AS [Sum Of Case Docs], Sum([Call Count]) AS [Sum Of Call Count]" & _
          " FROM [SheetName$RangeAddress]" & _
          " GROUP BY [LastName], [FirstName], [Agent ID];"

    SheetName = tbl.Parent.Name
    RangeAddress = tbl.Range.Address(False, False)

    SQL = Replace(SQL, "SheetName", SheetName)
    SQL = Replace(SQL, "RangeAddress", RangeAddress)

    getSQL = SQL
End Function

Upvotes: 4

0liveradam8
0liveradam8

Reputation: 778

Try this:

Sub Subroutine()
Dim currentrow As Integer
currentrow = 1
For i = 1 To 500
    If Cells(currentrow, 8) = Cells(i, 2) Then
        Cells(currentrow, 10) = Cells(currentrow, 10) + Cells(i, 4)
        Cells(currentrow, 11) = Cells(currentrow, 11) + Cells(i, 5)
    ElseIf IsNull(Cells(i, 2)) Or Cells(i, 2) = "" Then
        Exit For
    Else
        currentrow = currentrow + 1
        Cells(currentrow, 7) = Cells(i, 1)
        Cells(currentrow, 8) = Cells(i, 2)
        Cells(currentrow, 9) = Cells(i, 3)
        Cells(currentrow, 10) = Cells(i, 4)
        Cells(currentrow, 11) = Cells(i, 5)
    End If
Next i
End Sub

You'll have to adjust cell coordinates to match the coordinates of your cells.

Upvotes: 2

Related Questions