VBA Sum Multiple Columns and Duplicate Rows

Status
Not open for further replies.
K

kaneda0149

Board Regular
Joined
Aug 4, 2009
Messages
74
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!

Code: 
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
 

Excel Facts

How to fill five years of quarters?
Type 1Q-2023 in a cell. Grab the fill handle and drag down or right. After 4Q-2023, Excel will jump to 1Q-2024. Dash can be any character.
Sort by date Sort by votes
Try something like this...
Code: 
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
 
Upvote 0
Sorry. I missed one change that should have been made. Please disregard the above code and use this instead.
Code: 
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
 
Upvote 0
You the man, AlphaDog! Thank you so much. I see now how you added that additional column. Still learning ;o)
 
Upvote 0
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.

VBA Code: 
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
 
Upvote 0
Status
Not open for further replies.

Similar threads

N
  • Question
Copy Unique Values to New Sheet VBA
Replies
3
Views
125
nirvehex
N
P
  • Question
How to pass variable between subs that are stored as array element through CreateObject("Scripting.Dictionary")
Replies
1
Views
117
Micron
M
J
  • Solved
VBA to merge duplicate rows and sum values in certain column with adjustments
Replies
9
Views
390
Alex Blakenburg
A
S
  • Question
Using VBA to Flag and Calculate Overlapping Shift Times
Replies
0
Views
115
Snort
S
E
  • Solved
Auto open vba select column
Replies
8
Views
104
JerrExcel
JerrExcel

Forum statistics

Threads
1,216,045
Messages
6,128,484
Members
449,455
Latest member
jesski

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top