Thread: Sum and delete Duplicate Rows VBA

I need help to adapted Leith Ross codes to suit my needs. I find it in this tread (#3):
http://www.excelforum.com/excel-prog...o-formula.html
It working fine but I need to preserve my spreadsheet appearance for future use.
Below codes work with item descriptions in column A and qty in B.
My spreadsheet got item description in column D and qty in column B.
Is possible please, to change this codes to work with my spreadsheet?
Thank you.
This code to be work with Excel 2003

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

change the lines in bold

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("D1")
           Set RngEnd = Wks.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, -2).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

I get error:
"Run-time error '91':
Object variable or With block variable not set"

Debuger show bold line

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("D1")
           Set RngEnd = Wks.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, -2).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

It stop again in same spot as post #5

Now is running OK, but work only when I select range A1 instead of D1 and cell offset set to 1,offset -2 and D1 range make mess on Summary report. What I did is add another macro that sort column than CreateSummaryReport running and another macro to resort column again. Maybe from back side but work.
Thank you very much for help.

Hello mdbdesign,

Try this modified version of the macro and let me know if there are any issues.

Sub CreateSummaryReport()

 ' September 15, 2011 - Modified to work with cells D and B instead of A and B
 
  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, "D") = "Model Number"
             Cells(1, "B") = "Quantity"
             Rows(1).Font.Bold = True
             Columns("A:D").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("D1")
           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)               ' Cell in column "D"
               Item = Cell.Offset(0, -3).Value      ' Cell in column "A'
               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
       ' Clear the sheet except for the headers
        .UsedRange.Offset(1, 0).ClearContents
        
      ' Create 1-D arrays of the Model Numbers and Quantities
        Keys = DSO.Keys
        Items = DSO.Items
        
        ' Copy the Model Numbers and Quantities to the worksheet
          For I = 0 To DSO.Count - 1
            .Cells(I + 2, "D") = Keys(I)
            .Cells(I + 2, "B") = Items(I)
          Next I
          
       ' Sort the data in ascending order by Model Number
        .UsedRange.Sort Key1:=.Cells(2, "D"), Order1:=xlAscending, _
                        Header:=xlYes, Orientation:=xlSortColumns
      End With
    
    Set DSO = Nothing
    
End Sub

Attached is file after run macro and debugger screenshot.
Still not working...Any magic thing prevent it run properly?

Hello mdbdesign,

The code ran on the workbook you posted but it does not look like the data matches the column headers. The error you posted looks like there is a missing reference in you VBA project.

The code is for Excel 2003 and your profile indicates you are using Excel 2010. Are you running Windows XP, 7, or Vista?

At work I run 2003. At home I got 2010.
All run on wXP.
About missing references in VBA project...???
No clue. I am simple CAD guy with little knowledge of Excel macro.
But it work same way at work and at home, I am getting same error.

Hello mdbdesign,

How to Check the References in Your VBA Project

1. Open the workbook in Excel and press ALT+F11 this opens the Visual Basic Editor.
2. Press the keys ALT+T this displays the Tools menu.
3. Press the R key. This will display the references dialog.
4. Look in the drop down for any entries marked MISSING:.

Let me know what you find.

Not any of available references carry "missing" word.
But It is working when A and B column is in use?!?!