Excel VBA script to filter and sum

Question

I am using the code below and it works for filtering the unique name and totalting the value field. I recently have a need to expand upon the filtering of unique names to include other columns in the criteria. Please see the example output I am looking for. Any help would be appreciated.

 Sub SUM()

  Dim i, j, k As Integer
   i = 2
   j = 2

Range("D1").Value = "NAME"
Range("E1").Value = "VALUE"

'copy the first value of column A to column D
Range("D2").Value = Range("A2").Value

'cycle to read all values of column B and sum it to column E; will run until find a blank cell
While Range("A" & i).Value <> ""

    'this check if actual value of column A is equal to before value of column A, if true just add the column B value to E
    'else, look for the row in column D where is the same value of column A, if it doesn't exist code create the value
    'in column D and E
    If Range("A" & i).Value = Range("A" & i - 1).Value Then
        Range("E" & j).Value = Range("E" & j).Value + Range("B" & i).Value
    Else
        flag = 1
        While Range("D" & flag).Value <> ""
            If Range("A" & i).Value = Range("D" & flag).Value Then
                j = flag
                Range("E" & j).Value = Range("E" & j).Value + Range("B" & i).Value
                flag = Range("D1").End(xlDown).Row
            Else
                j = 0
            End If
            flag = flag + 1
        Wend
        If j = 0 Then
            Range("D1").End(xlDown).Offset(1, 0).Value = Range("A" & i).Value
            Range("E1").End(xlDown).Offset(1, 0).Value = Range("B" & i).Value
            j = Range("E1").End(xlDown).Row
        End If
    End If

    i = i + 1
Wend
MsgBox "End"

End Sub

Currently outputs like this:

 Name  Value       Name    Sum
    A           1       A     13
    A           2       B      7
    B           1       C      3
    B           3           
    C           2           
    A           1           
    B           2           
    A           3           
    B           1           
    A           2           
    A           4           
    C           1      

I would like to have it export data like this example:

Name  Code  Date     Value       Name   Code  Date   Sum
   A   101  3/10/17      1       A     101   3/10/17    9
   A   101  3/10/17      2       A     102   3/10/17    4
   B   102  3/10/17      1       B     101   3/10/17    3
   B   101  3/10/17      3       B     102   3/10/17    2
   C   102  3/8/17       2       B     101   3/8/17     2
   A   102  3/10/17      1       C     102   3/8/17     2
   B   101  3/8/17       2       C     102   3/10/17    1   
   A   102  3/10/17      3         
   B   102  3/10/17      1           
   A   101  3/10/17      2           
   A   101  3/10/17      4           
   C   102  3/10/17      1           

Answer 1

As long as your columns go A,B,C,D then F,G,H,I then below code should work. Let me know if it works for you.

Sub CountCodes()

With Application
    .ScreenUpdating = False
    .Calculation = xlCalculationManual
End With

Dim wbk As Workbook
Dim ws As Worksheet
Dim wsRow As Long, newRow As Long
Dim Names() As String
Dim Found As Boolean
Dim x As Integer, y As Integer, z As Integer, myCount As Integer, mySum As Integer
Dim Cell As Range

Set wbk = ThisWorkbook
Set ws = wbk.Worksheets(1)

ReDim Names(0 To 0) As String
ReDim Codes(0 To 0) As String
ReDim Dates(0 To 0) As String

newRow = 1

With ws
    'Find last row of data
    wsRow = .Range("A" & .Rows.Count).End(xlUp).Row

    'Loop through Column A to fill array
    For Each Cell In .Range(.Cells(2, 1), .Cells(wsRow, 1))
        'Fill Names array
        Found = (IsInArray(Cell.Value2, Names) > -1)
        If Found = False Then
            Names(UBound(Names)) = Cell.Value2
            If Cell.Row <> wsRow Then
                ReDim Preserve Names(0 To UBound(Names) + 1) As String
            End If
        End If

        'Fill Codes array
        Found = (IsInArray(Cell.Offset(0, 1).Value2, Codes) > -1)
        If Found = False Then
            Codes(UBound(Codes)) = Cell.Offset(0, 1).Value2
            If Cell.Row <> wsRow Then
                ReDim Preserve Codes(0 To UBound(Codes) + 1) As String
            End If
        End If

        'Fill Dates array
        Found = (IsInArray(Cell.Offset(0, 2).Value2, Codes) > -1)
        If Found = False Then
            Dates(UBound(Dates)) = Cell.Offset(0, 2).Value
            If Cell.Row <> wsRow Then
                ReDim Preserve Codes(0 To UBound(Dates) + 1) As String
            End If
        End If
    Next
    'Add Autofilter if off
    If .AutoFilterMode = False Then
        .Range("A1").AutoFilter
    End If

    For x = LBound(Names) To UBound(Names)
        .Range("A1").AutoFilter Field:=1, Criteria1:=Names(x)
        For y = LBound(Codes) To UBound(Codes)
            .Range("B1").AutoFilter Field:=2, Criteria1:=Codes(y)
            For z = LBound(Dates) To UBound(Dates)
                .Range("C1").AutoFilter Field:=3, Criteria1:=Dates(z)
                For Each Cell In .Range("A1:A" & wsRow).SpecialCells(xlCellTypeVisible)
                    myCount = myCount + 1
                Next
                If myCount > 1 Then
                    For Each Cell In .Range("D2:D" & wsRow).SpecialCells(xlCellTypeVisible)
                        mySum = mySum + Cell.Value2
                    Next
                    'Find last row in new data
                    newRow = newRow + 1
                    .Cells(newRow, 6) = Names(x)
                    .Cells(newRow, 7) = Codes(y)
                    .Cells(newRow, 8) = Dates(z)
                    .Cells(newRow, 9) = mySum
                End If
                myCount = 0
                mySum = 0
            Next z
        Next y
    Next x
    .ShowAllData
End With

Erase Names
Erase Codes
Erase Dates

With Application
    .ScreenUpdating = True
    .Calculation = xlCalculationAutomatic
End With

End Sub

Function IsInArray(stringToBeFound As String, arr As Variant) As Long
'http://stackoverflow.com/questions/10951687/how-to-search-for-string-in-an-array
'Boolean = (IsInArray(StringToFind, ArrayToSearch) > -1)
    Dim i As Long
    ' default return value if value not found in array
    IsInArray = -1

For i = LBound(arr) To UBound(arr)
    If StrComp(stringToBeFound, arr(i), vbTextCompare) = 0 Then
        IsInArray = i
        Exit For
    End If
Next i

End Function

Answer 2

I used a pivot table in Excel 2016 to generate this view, since you are not opposed to using a Pivot Table. If Excel can do this out of the box, and you are happy with how it looks and behaves, there is no real need for custom VBA in this case.

Just do the following:

• Highlight your data, then insert > pivot table
  • I placed the pivot table in cell F1 of Sheet 1
• Add Name, Code, and Date to the Rows of the pivot table
• Add Value to the Values of the pivot table. It should default to Sum.
• Click on the pivot table, then in the pivot table tools > design tab in the ribbon, go to the "Layout" ribbon group:
  • On the Report Layout Dropdown:
    • Click "Show in Tabular Form"
    • Click "Repeat All Item Labels"
  • On the Subtotals Dropdown:
    • Click "Do Not Show Subtotals"
  • On the Grand totals Dropdown:
    • Click "off for rows and columns"

Answer 3

You could use Dictionary object:

Option Explicit

Sub ListTotals()
    Dim c As Range, dataRng As Range
    Dim key As Variant

    Set dataRng = Range("A2", Cells(Rows.Count, 1).End(xlUp))
    With CreateObject("Scripting.Dictionary")
        For Each c In dataRng
            key = Join(c.Resize(,3), "|")
            .Item(key) = .Item(key) + c.Offset(,4)
        Next c

        With dataRng.Resize(.Count)
            .Offset(,5) = Application.Transpose(.Keys)
            .Offset(,8) = Application.Transpose(.Items)
            .Offset(,5).TextToColumns DataType:=xlDelimited, Other:=True, OtherChar:="|", FieldInfo:= Array(Array(1, 2), Array(3, 3))
        End With
    End With
End Sub