Sum and delete Duplicate Rows VBA MACRO FORMULA

Hello ARNO,

When this macro is run it will create a summary report. The data is listed alphabetically form A to Z by model number. Leading and trailing spaces and case are ignored when gathering the data. If the sheet doesn't already exist the macro will create it.

Sub CreateSummaryReport()

  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"
             Cells(1, "A") = "Model Number"
             Cells(1, "B") = "Quantity"
             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

Adding the Macro
1. Copy the macro above pressing the keys CTRL+C
2. Open your workbook
3. Press the keys ALT+F11 to open the Visual Basic Editor
4. Press the keys ALT+I to activate the Insert menu
5. Press M to insert a Standard Module
6. Paste the code by pressing the keys CTRL+V
7. Make any custom changes to the macro if needed at this time.
8. Save the Macro by pressing the keys CTRL+S
9. Press the keys ALT+Q to exit the Editor, and return to Excel.

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.

Leith Ross's approach did not work. It stated:

Runtime error '91.'
Object Variable or With Bock Variable not set.


When I debugged it, it highlighted the following line:

The If Wks.Name <> SumWks.Name Then

StephenR's approach also did not work, it stated the following:

Runtime error '1004'
The extract range has a missing or illegal field name.

debugged, highlighted line:

rData.AdvancedFilter xlFilterCopy, copytorange:=Range("C1"), unique:=True

How can I fix this? I need to delete the duplicate model numbers but sum their quantities in one row for each. Thanks for your responses!

Hello ARNO,

The macro I wrote works in Excel 2003. Which version of Excel are you using?

Hello ARNO,

Sorry, it is my fault. I changed the macro but didn't post the corrected copy. The correction is in blue.

Sub CreateSummaryReport()

  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") = "Model Number"
             Cells(1, "B") = "Quantity"
             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

Welcome to the forum.

Please take a few minutes to read the forum rules, and then start your own thread.

Same goes for you, vijay.