Thread: Concatenate Cells Based on Dates and Sum Totals

Hi,

I need some help with creating a macro using VBA code. Basically I have a spreadsheet that has transactional data and I would like to aggregate it by date and have one row per each date. What I have is below:

Sales Rep ID, Date Entered, Occurence, Total Revenue
32113, 7/1/2011, 1, $1.00
32113, 7/1/2011, 1, $20.00
32113, 7/1/2011, 2, $5.00
32113, 7/1/2011, 2, $0.00
32113, 6/28/2011, 2, $8.00
32113, 6/28/2011, 2, $0.00

AND the result I need to get to with the VBA code is below:

Sales Rep ID, Date Entered, Occurence , Total Revenue
32113, 7/1/2011, 6, $26.00
32113, 6/28/2011, 4, $8.00



Thank You
Neha Gulati

Hello NGNG,

This macro will condense the transactions by rep and date. Copy and paste this code into a separate VBA module in your workbook. The macro assumes the data is on "Sheet1" and starts in cell "A2". You can change the worksheeet name and the starting cell if you need to. They are marked in bold.

Sub CondenseTransactions()

 ' Thread: http://www.excelforum.com/excel-programming/787581-creating-a-macro-using-vba-code.html
 ' Poster: NGNG
 ' Author: Leith Ross
 
  Dim Cell As Range
  Dim Entry As Variant
  Dim ID As Variant
  Dim R As Long
  Dim Rng As Range
  Dim RngEnd As Range
  Dim TAL As Object     'TransAction Log
  Dim Wks As Worksheet
  
    Set Wks = Worksheets("Sheet1")
    Set Rng = Wks.Range("A2")
    
      Set RngEnd = Wks.Cells(Rows.Count, Rng.Column).End(xlUp)
      If RngEnd.Row < Rng.Row Then Exit Sub Else Set Rng = Wks.Range(Rng, RngEnd)
    
      Set TAL = CreateObject("Scripting.Dictionary")
      TAL.CompareMode = vbTextCompare
      
        For Each Cell In Rng
          ID = Trim(Cell) & "," & Trim(Cell.Offset(0, 1))
          If ID <> "," Then
            If Not TAL.Exists(ID) Then
               ReDim Entry(1)
                 Entry(0) = Cell.Offset(0, 2)
                 Entry(1) = Cell.Offset(0, 3)
               TAL.Add ID, Entry
            Else
               Entry = TAL(ID)
                 Entry(0) = Entry(0) + Cell.Offset(0, 2)
                 Entry(1) = Entry(1) + Cell.Offset(0, 3)
               TAL(ID) = Entry
            End If
          End If
        Next Cell
      
      Rng.Resize(ColumnSize:=4).ClearContents
      
      Application.ScreenUpdating = False
        For Each ID In TAL
          Rng.Resize(1, 2).Offset(R, 0) = Split(ID, ",")
          Rng.Offset(R, 2).Resize(1, 2) = TAL(ID)
          R = R + 1
        Next ID
      Application.ScreenUpdating = True
     
End Sub

To Run the Macro...
To run the macro from Excel, open the workbook, and press ALT+F8 to display the Run Macro Dialog. Double Click

the macro's name to Run it.

Thanks for the reply. My requirements have changed a bit. Attached is the raw data I will begin with and the sample result set I need to get to on a separate worksheet using VB code. The requirements are to count unique number of 'Account Numbers' per 'Date' per 'ID' where 'Work Orders Types' = "IN" or "UP" and 'Total Revenue' > 0:

Hello NGNG,

I made the changes to the macro and have tested it. It appears to work on the sample but the real test will be on the actual data. Here is the macro which has been added to the attached workbook.

Sub CondenseTransactions()

 ' Thread: http://www.excelforum.com/excel-programming/787581-creating-a-macro-using-vba-code.html
 ' Poster: NGNG
 ' Author: Leith Ross
 ' Updated: August 18, 2011
 
 ' The requirements are to count unique number of Account Numbers ("B") per Date ("G") per ID ("C")
 ' where Work Orders Types ("E") = "IN" or "UP" and Revenue ("I") > 0:
 
  Dim Cell As Range
  Dim Entry As Variant
  Dim ID As Variant
  Dim R As Long
  Dim ResRng As Range
  Dim ResWks As Worksheet
  Dim RawRng As Range
  Dim RngEnd As Range
  Dim RawWks As Worksheet
  Dim TAL As Object         'TransAction Log
  
  
  ' Assign the worksheets and their starting ranges
    Set RawWks = Worksheets("Raw Data")
    Set RawRng = RawWks.Range("B2")
    
    Set ResWks = Worksheets("Result")
    Set ResRng = ResWks.Range("A2")
    
    ' Find the cell of the last ID entered
      Set RngEnd = RawWks.Cells(Rows.Count, RawRng.Column).End(xlUp)
      If RngEnd.Row < RawRng.Row Then Exit Sub Else Set RawRng = RawWks.Range(RawRng, RngEnd)
    
      Set TAL = CreateObject("Scripting.Dictionary")
      TAL.CompareMode = vbTextCompare
      
      ' IDs are in column "B" on RawData worksheet
        For Each Cell In RawRng.Cells
        
          Addx1 = Cell.Address
          
          ' Combine ID and Account Number and Entry Date separated by commas
            ID = Trim(Cell) & "," & Trim(Cell.Offset(0, 1)) & Cell.Offset(0, 5).Value
            
          ' Check there is an ID and Account Number present
            If ID <> "," Then
             
             ' Is this a new ID ?
                If Not TAL.Exists(ID) Then
                  ' Yes
                    ReDim Entry(1)
                      Entry(0) = Cell.Offset(0, 5).Value    ' Entry Date
                      Entry(1) = 0                          ' Unique count
                    TAL.Add ID, Entry
                Else
                  ' No
                    Addx2 = Cell.Address
                    Entry = TAL(ID)
                End If
                
                If (Cell.Offset(0, 3) = "IN" Or Cell.Offset(0, 3) = "UP") And Cell.Offset(0, 7) > 0 Then
                   Entry(1) = Entry(1) + 1
                End If
                
              TAL(ID) = Entry
                
            End If
            
        Next Cell
      
    ' Clear the Result worksheet except for the headers in row 1
      ResWks.UsedRange.Offset(1, 0).ClearContents
      
    ' Copy the results to the Result worksheet
      Application.ScreenUpdating = False
        For Each ID In TAL
          ResRng.Offset(R, 0) = Split(ID, ",")(0)
          ResRng.Offset(R, 1).Resize(1, 2) = TAL(ID)
          R = R + 1
        Next ID
      Application.ScreenUpdating = True
     
End Sub