Delete duplicates as per column E, Sum up values on col F, G... (please help)

**rain4u** · 07-05-2011, 06:20 AM

Hi all
I'm bit in a pickle. I'm supposed to to do presentation on Thursday and I have now realised one of my macro is wrong. I have taken a macro from another project and adjusted it to my need. I thought I had it right and only now realised it gets it wrong. On other project the values were numeric numbers and the code was working fine. On this occasion I need it to have a look of some part nubmers which also contain letters (i .e. its a string of text.) . Like this for example
L57241218200
L57256748200
KNA12A3K20202C01

Anyway this is what the code needs to do. It needs to look in column E (col 5). If there is a duplicate value it needs to remove all rows except the bottom one. Now at same time it needs to sum up values in column F, G, H and I.

KNA12A3K21018C03 --------- 1 --------- 1 --------- 0 --------- 1
KNA12A3K21018C03 --------- 3 --------- 3 --------- 0 --------- 1
KNA12A3K21018C03 --------- 3 --------- 3 --------- 0 --------- 1
KNA12A3K21018C03 --------- 6 --------- 3 --------- 0 --------- 1
KNA12A3K21018C03 --------- 3 --------- 3 --------- 0 --------- 1
KNA12A3K21018C03 --------- 10 --------- 7 --------- 0 --------- 1
----------------------------------------------------------------------------------------------------------------------------------
So it would keep the last row of these duplicates and sum up like this
KNA12A3K21018C03 --------- 26 --------- 20 --------- 0 --------- 6

Current code is following. But feel free to do new one from scratch or do it anyway as you would know as this is bit messy with unwanted stuff there as well.

Sub Chart_prepare_TOP30_by_parts()
    Dim sh As Worksheet, lastRow As Long
   Dim r As Long, myRange, dupeChkCol As String
   Dim olddupeChkCol As String, shedDiff As Long, promDiff As Long, promPullFor As Long, promDateSlipp As Long, ReasonProv As Long
   Dim myManId As String
   Dim myKey As String, myRow As Long
   On Error GoTo lblErr
   Set sh = ActiveSheet
   sh.AutoFilterMode = 0
   lastRow = sh.Cells(Rows.Count, 1).End(xlUp).Row
   myRange = sh.Range("a2").Resize(lastRow - 1, 12)
   For r = UBound(myRange, 1) To 0 Step -1
      If r = 0 Then
         dupeChkCol = Chr(255)
      Else
         dupeChkCol = myRange(r, 5)
      End If
      If dupeChkCol = olddupeChkCol Then
         If myRange(r, 1) <> myKey Then
            myManId = myRange(r, 1) & ", " & myManId
         End If
        myKey = myRange(r, 1)
        shedDiff = shedDiff + myRange(r, 6)
        promDiff = promDiff + myRange(r, 7)
        promPullFor = promPullFor + myRange(r, 8)
        promDateSlipp = promDateSlipp + myRange(r, 9)
        ReasonProv = ReasonProv + myRange(r, 10)
      Else
         If olddupeChkCol <> "" Then
            'scrive
            myRange(myRow, 12) = "keep"
                        myRange(myRow, 6) = shedDiff
                        shedDiff = 0
                        myRange(myRow, 7) = promDiff
                        promDiff = 0
                        myRange(myRow, 8) = promPullFor
                        promPullFor = 0
                        myRange(myRow, 9) = promDateSlipp
                        promDateSlipp = 0
                        myRange(myRow, 10) = ReasonProv
                        ReasonProv = 0
         End If
         If r <> 0 Then
            myManId = myRange(r, 1)
            shedDiff = myRange(r, 6)
            promDiff = myRange(r, 7)
            promPullFor = myRange(r, 8)
            promDateSlipp = myRange(r, 9)
            ReasonProv = myRange(r, 10)
            myKey = myManId
            
            myRow = r
         End If
         olddupeChkCol = dupeChkCol
      End If
   Next r
   Application.ScreenUpdating = False
   'put data on screen
   sh.Range("a2").Resize(lastRow - 1, 12) = myRange
   'delete duplicated rows
   ' With ActiveSheet.Columns(12)
   '         .AutoFilter Field:=1, Criteria1:="<>keep"
   '         .Resize(Rows.Count - 1).Offset(1).SpecialCells(12).EntireRow.Delete
   '         If .Parent.AutoFilterMode = True Then .AutoFilter
   ' End With
sh.Range("L:L").AutoFilter Field:=1, Criteria1:="<>keep"
  sh.Rows("2:" & lastRow).Delete
   sh.AutoFilterMode = False


lblExit:
   Exit Sub
lblErr:
'   Stop
'   Resume Next
'   MsgBox ("Error occurred: " & Err.Number & " - TOP30PARTS " & Err.Description)
   Resume lblExit
End Sub

I have attached spreadsheet with current code. It has sheet "After" to give you an idea how it should look like (there might be mistakes on it on "after" sheet as I did it manually.).

Im bit desperate as I have a presentation on Thursaday where I would need a this macro as its part of my other macros. Im almost 100% done with my stuff and now Im suddenly in trouble. Help would be most appreciated.
Cheers
Rain

**StephenR** · 07-05-2011, 06:59 AM

Maybe this, though not completely sure about your output:

Sub x()

Dim r As Range, n As Long, wf As WorksheetFunction

Set wf = WorksheetFunction

With Sheet15
    n = .Range("A" & Rows.Count).End(xlUp).Row
    .Range("L2:L" & n).Formula = "=COUNTIF($E$2:E2,E2)"
    .Range("M2").FormulaArray = "=MAX(IF($E$2:$E$" & n & "=E2,$L$2:$L$" & n & "))"
    .Range("M2").AutoFill .Range("M2:M" & n)
    For Each r In .Range("E2:E" & n)
        If r.Offset(, 8) = r.Offset(, 7) Then
            Sheet2.Range("A" & Rows.Count).End(xlUp)(2).Resize(, 11).Value = _
                r.Offset(, -4).Resize(, 11).Value
            Sheets("After").Range("F" & Rows.Count).End(xlUp) = wf.SumIf(.Columns(5), r, .Columns(6))
            Sheet("After").Range("G" & Rows.Count).End(xlUp) = wf.SumIf(.Columns(5), r, .Columns(7))
            Sheet("After").Range("H" & Rows.Count).End(xlUp) = wf.SumIf(.Columns(5), r, .Columns(8))
            Sheet("After").Range("I" & Rows.Count).End(xlUp) = wf.SumIf(.Columns(5), r, .Columns(9))
        End If
    Next r
    .Columns(12).Resize(, 2).ClearContents
End With

End Sub

**MickG** · 07-05-2011, 10:34 AM

Try this:-

Sub MG05Jul54
Dim Rng     As Range
Dim Dn      As Range
Dim nRng    As Range
Dim Q       As Variant
Dim K
Dim nnRng   As Range
Dim Ac      As Integer
Dim Rw      As Range
Dim R       As Range

Set Rng = Range(Range("E2"), Range("E" & rows.count).End(xlUp))
With CreateObject("scripting.dictionary")
.CompareMode = vbTextCompare
    For Each Dn In Rng
       If Not .Exists(Dn.value) Then
            .Add Dn.value, Array(Dn, Dn)
        Else
            Q = .Item(Dn.value)
            Set Q(0) = Dn
            Set Q(1) = Union(Q(1), Dn)
            .Item(Dn.value) = Q
       End If
Next

For Each K In .keys
    If Not .Item(K)(1) Is Nothing Then
      For Ac = 1 To 4
        .Item(K)(0).Offset(, Ac) = Application.sum(.Item(K)(1).Offset(, Ac))
         Next Ac

    For Each R In .Item(K)(1).Areas
        For Each Rw In R
            If Not Rw.Address = .Item(K)(0).Address Then
                If nnRng Is Nothing Then
                    Set nnRng = Rw
                Else
                    Set nnRng = Union(nnRng, Rw)
                End If
            End If
        Next Rw
    Next R
End If
Next K
If Not nnRng Is Nothing Then
    nnRng.EntireRow.Delete
End If
End With
End Sub

Regards Mick

**rain4u** · 07-05-2011, 05:32 PM

Thank you both very much. I decided to go with your code MickG. It works like a charm. Thanks to you I can have some dynamic charts that will look something like this
http://imageshack.us/photo/my-images/837/thankyouq.jpg/

Now I wont embarrass myself at the meeting. Totally saved by you.
Cheers
Rain