VBA Sum Multiple Columns and Duplicate Rows

[kaneda0149]

Hi,

I found this fabulous code that sum the column and delete duplicate rows. It also put the updated data in a new sheet. This code is based on 2 columns; A and B. Column A being the duplicate rows and column B the values.

Can someone help in showing me how to sum column C of values as well. So the data would have 3 columns that looks like this:

A B C
Model type1 type2
1234 2 1
4321 1 4
1234 2 3
4321 1 1

A B C
Model type1 type2
1234 4 4
4321 2 5

Here's the original code that works on 2 columns (which I would love to maintain if possible). All the help would be greatly appreciated. Thanks!

Sub CreatePESummary()
       
  Dim Cell As Range
  Dim Data() As Variant
  Dim DSO As Object
  Dim Key As Variant
  Dim Keys As Variant
  Dim I As Long
  Dim Item As Variant
  Dim Items As Variant
  Dim Rng As Range
  Dim RngEnd As Range
  Dim SumWks As Worksheet
  Dim Wks As Worksheet
  
    On Error Resume Next
      Set SumWks = Worksheets("Summary Report")
        If Err = 9 Then
           Err.Clear
           Worksheets.Add.Name = "Summary Report"
           Set SumWks = ActiveSheet
             Cells(1, "A") = "Investment"
             Cells(1, "B") = "Total Amount"
             Rows(1).Font.Bold = True
             Columns("A:B").AutoFit
        End If
    On Error GoTo 0
    
    Set DSO = CreateObject("Scripting.Dictionary")
    DSO.CompareMode = vbTextCompare
    
      For Each Wks In Worksheets
        If Wks.Name <> SumWks.Name Then
           Set Rng = Wks.Range("A1")
           Set RngEnd = Rng.Cells(Rows.Count, Rng.Column).End(xlUp)
           Set Rng = IIf(RngEnd.Row < Rng.Row, Rng, Wks.Range(Rng, RngEnd))
             For Each Cell In Rng
               Key = Trim(Cell.Value)
               Item = Cell.Offset(0, 1).Value
               If Key <> "" Then
                 If Not DSO.Exists(Key) Then
                    DSO.Add Key, Item
                 Else
                    DSO(Key) = DSO(Key) + Item
                 End If
               End If
             Next Cell
        End If
      Next Wks
      
      With SumWks
        .UsedRange.Offset(1, 0).ClearContents
        Keys = DSO.Keys
        Items = DSO.Items
          For I = 0 To DSO.Count - 1
            .Cells(I + 2, "A") = Keys(I)
            .Cells(I + 2, "B") = Items(I)
          Next I
        .UsedRange.Sort Key1:=.Cells(2, 1), Order1:=xlAscending, _
                        Header:=xlYes, Orientation:=xlSortColumns
      End With
    
    Set DSO = Nothing
    
End Sub

 

[AlphaFrog]

Try something like this...

Sub CreatePESummary2()

  'Sums columns B and C
       
  Dim Cell As Range
  Dim Data() As Variant
  Dim DSO As Object
  Dim DSO_c As Object                                   '
  Dim Key As Variant
  Dim Keys As Variant
  Dim I As Long
  Dim Item As Variant
  Dim Item_c As Variant                                 '
  Dim Items As Variant
  Dim Items_c As Variant                                '
  Dim Rng As Range
  Dim RngEnd As Range
  Dim SumWks As Worksheet
  Dim Wks As Worksheet
  
    On Error Resume Next
      Set SumWks = Worksheets("Summary Report")
        If Err = 9 Then
           Err.Clear
           Worksheets.Add.Name = "Summary Report"
           Set SumWks = ActiveSheet
             Cells(1, "A") = "Investment"
             Cells(1, "B") = "Total Amount"
             Cells(1, "C") = "Total Amount"             '
             Rows(1).Font.Bold = True
             Columns("A:C").AutoFit
        End If
    On Error GoTo 0
    
    Set DSO = CreateObject("Scripting.Dictionary")
    Set DSO_c = CreateObject("Scripting.Dictionary")    '
    DSO.CompareMode = vbTextCompare
    DSO_c.CompareMode = vbTextCompare                   '
    
      For Each Wks In Worksheets
        If Wks.Name <> SumWks.Name Then
           Set Rng = Wks.Range("A1")
           Set RngEnd = Rng.Cells(Rows.Count, Rng.Column).End(xlUp)
           Set Rng = IIf(RngEnd.Row < Rng.Row, Rng, Wks.Range(Rng, RngEnd))
             For Each Cell In Rng
               Key = Trim(Cell.Value)
               Item = Cell.Offset(0, 1).Value
               Item_c = Cell.Offset(0, 2).Value         '
               If Key <> "" Then
                 If Not DSO.Exists(Key) Then
                    DSO.Add Key, Item
                    DSO_c.Add Key, Item_c               '
                 Else
                    DSO(Key) = DSO(Key) + Item
                    DSO_c(Key) = DSO(Key) + Item_c      '
                 End If
               End If
             Next Cell
        End If
      Next Wks
      
      With SumWks
        .UsedRange.Offset(1, 0).ClearContents
        Keys = DSO.Keys
        Items = DSO.Items
        Items_c = DSO_c.Items                           '
          For I = 0 To DSO.Count - 1
            .Cells(I + 2, "A") = Keys(I)
            .Cells(I + 2, "B") = Items(I)
            .Cells(I + 2, "C") = Items_c(I)             '
          Next I
        .UsedRange.Sort Key1:=.Cells(2, 1), Order1:=xlAscending, _
                        Header:=xlYes, Orientation:=xlSortColumns
      End With
    
    Set DSO = Nothing
    Set DSO_c = Nothing                                 '
    
End Sub

 

[AlphaFrog]

Sorry. I missed one change that should have been made. Please disregard the above code and use this instead.

Sub CreatePESummary2()

  'Sums columns B and C
       
  Dim Cell As Range
  Dim Data() As Variant
  Dim DSO As Object
  Dim DSO_c As Object                                   '
  Dim Key As Variant
  Dim Keys As Variant
  Dim I As Long
  Dim Item As Variant
  Dim Item_c As Variant                                 '
  Dim Items As Variant
  Dim Items_c As Variant                                '
  Dim Rng As Range
  Dim RngEnd As Range
  Dim SumWks As Worksheet
  Dim Wks As Worksheet
  
    On Error Resume Next
      Set SumWks = Worksheets("Summary Report")
        If Err = 9 Then
           Err.Clear
           Worksheets.Add.Name = "Summary Report"
           Set SumWks = ActiveSheet
             Cells(1, "A") = "Investment"
             Cells(1, "B") = "Total Amount"
             Cells(1, "C") = "Total Amount"             '
             Rows(1).Font.Bold = True
             Columns("A:C").AutoFit
        End If
    On Error GoTo 0
    
    Set DSO = CreateObject("Scripting.Dictionary")
    Set DSO_c = CreateObject("Scripting.Dictionary")    '
    DSO.CompareMode = vbTextCompare
    DSO_c.CompareMode = vbTextCompare                   '
    
      For Each Wks In Worksheets
        If Wks.Name <> SumWks.Name Then
           Set Rng = Wks.Range("A1")
           Set RngEnd = Rng.Cells(Rows.Count, Rng.Column).End(xlUp)
           Set Rng = IIf(RngEnd.Row < Rng.Row, Rng, Wks.Range(Rng, RngEnd))
             For Each Cell In Rng
               Key = Trim(Cell.Value)
               Item = Cell.Offset(0, 1).Value
               Item_c = Cell.Offset(0, 2).Value         '
               If Key <> "" Then
                 If Not DSO.Exists(Key) Then
                    DSO.Add Key, Item
                    DSO_c.Add Key, Item_c               '
                 Else
                    DSO(Key) = DSO(Key) + Item
                    DSO_c(Key) = DSO_c(Key) + Item_c      '
                 End If
               End If
             Next Cell
        End If
      Next Wks
      
      With SumWks
        .UsedRange.Offset(1, 0).ClearContents
        Keys = DSO.Keys
        Items = DSO.Items
        Items_c = DSO_c.Items                           '
          For I = 0 To DSO.Count - 1
            .Cells(I + 2, "A") = Keys(I)
            .Cells(I + 2, "B") = Items(I)
            .Cells(I + 2, "C") = Items_c(I)             '
          Next I
        .UsedRange.Sort Key1:=.Cells(2, 1), Order1:=xlAscending, _
                        Header:=xlYes, Orientation:=xlSortColumns
      End With
    
    Set DSO = Nothing
    Set DSO_c = Nothing                                 '
    
End Sub

 

[kaneda0149]

You the man, AlphaDog! Thank you so much. I see now how you added that additional column. Still learning ;o)

 

[Noobiee]

Is there a possible way to have this code work on a specific sheet rather than all work sheets and spits out the results in the same sheet that the data is being pulled from rather than to a new sheet?
My data already has header dont care too much about keeping the headers if that matters .


I added the code I am using but my problem with this code is that the data for my 3rd column C is not adding correctly and removes duplicates at different ranges everytime not based one range of filled cells the data always change in size only for rows.

Sub PPA()


With Worksheets("Induct") '


    With .Range("A1:B3500").Resize(.Cells(.Rows.Count, 3).End(xlUp).Row)

        .Copy

        With .Offset(, .Columns.Count + 1)

            .PasteSpecial xlPasteValues '

             .Columns(2).Offset(1).Resize(.Rows.Count - 1, 1).FormulaR1C1 = "=SUMIF(C1,RC1,C[-" & .Columns.Count + 1 & "])"

            .Value = .Value

            .RemoveDuplicates 1, xlYes

           .Columns(3).Offset(1).Resize(.Rows.Count - 1, 1).FormulaR1C1 = "=SUMIF(C1,RC1,C[-" & .Columns.Count + 1 & "])"

            .Value = .Value

            .RemoveDuplicates 1, xlYes

          

             Sheets("Induct").Select

    Columns("F:F").Select

    ActiveSheet.Range("$F$1:$F$240").RemoveDuplicates Columns:=1, Header:=xlYes

    

    

        End With

      

        End With


End With

 

[mohadin]

Too late

 

[Fluff]

@Noobiee
Duplicate to: VBA Sum Multiple Columns and Duplicate Rows using specific sheets

In future, please do not post the same question multiple times. Per Forum Rules (#12), posts of a duplicate nature will be locked or deleted.

In relation to your question here, I have closed this thread so please continue in the linked thread.