clear the contents of duplicate row on condition

[ramanujam]

Hi all,

I need a macro to clear the contents of the row on condition.
The condition is on based on values the A,D,E i need to clear the contents of duplicate rows.
Suppose if i have data like this then


A| B| C| D | E
1|qq ww rr xx rr
2|dd ff yy xx yy
3|qq gg sa hh nn
4|qq vv cc xx rr
5|qq oo mm hh nn
6|qq gg fa qq ll

then output should be like


A| B| C| D | E
1|qq ww rr xx rr
2|dd ff yy xx yy
3|qq gg sa hh nn
4|
5|
6|qq gg fa qq ll

Like this i needed..
Can anyone pls help me on this..
Thanks in advance...

 

[ramanujam]

Hi all,
Is there any update for the above requirement...

Thanks in advance...

 

[MickG]

Hi, Try This:-
Nb:- Alter destination range at Bottom of code to suit.

Sub DupBk()
Dim Rng As Range, Dn As Range
Dim TwDn As String
Dim Ray, C As Long, BLK As Integer

Set Rng = Range(Range("A1"), Range("A" & Rows.Count).End(xlUp))

ReDim Ray(1 To Rng.Count, 1 To 5)

With CreateObject("scripting.dictionary")
    .comparemode = vbTextCompare
    For Each Dn In Rng
       TwDn = Dn & Dn.Offset(, 3) & Dn.Offset(, 4)
       If Not .Exists(TwDn) Then
            C = C + 1
            Ray(C, 1) = Dn: Ray(C, 2) = Dn.Offset(, 1): Ray(C, 3) = Dn.Offset(, 2)
            Ray(C, 4) = Dn.Offset(, 3): Ray(C, 5) = Dn.Offset(, 4)
            .Add TwDn, ""
        Else
                C = C + 1
            For BLK = 1 To 5
                Ray(C, BLK) = ""
            Next BLK
        End If
    Next Dn
End With
Range("G1").Resize(Rng.Count, 5) = Ray
           
  End Sub

Regards Mick

 

[ramanujam]

Hi MickG,

Thanks for u r reply..
Its working very super..
you have wriiten upto to 5 columns how to change this req to 10 columns...
Can u please help me on this..
Thanks in advance...

 

[MickG]

Hi, Try this, Result start "L1"

Sub DupBk2()
Dim Rng As Range, Dn As Range
Dim TwDn As String
Dim Ray, C As Long, BLK As Integer

Set Rng = Range(Range("A1"), Range("A" & Rows.Count).End(xlUp))

ReDim Ray(1 To Rng.Count, 1 To 10)

With CreateObject("scripting.dictionary")
    .comparemode = vbTextCompare
    For Each Dn In Rng
       TwDn = Dn & Dn.Offset(, 3) & Dn.Offset(, 4)
       If Not .Exists(TwDn) Then
            C = C + 1
            For BLK = 0 To 9
                Ray(C, BLK + 1) = Dn.Offset(, BLK)
            Next BLK
              .Add TwDn, ""
        Else
                C = C + 1
            For BLK = 1 To 5
                Ray(C, BLK) = ""
            Next BLK
        End If
    Next Dn
End With
Range("L1").Resize(Rng.Count, 10) = Ray
           
  End Sub

Regards Mick

 

[ramanujam]

thanks mickg...
Its working very super....
Thanks a lot man...

Hi, Try this, Result start "L1"

Sub DupBk2()
Dim Rng As Range, Dn As Range
Dim TwDn As String
Dim Ray, C As Long, BLK As Integer
 
Set Rng = Range(Range("A1"), Range("A" & Rows.Count).End(xlUp))
 
ReDim Ray(1 To Rng.Count, 1 To 10)
 
With CreateObject("scripting.dictionary")
    .comparemode = vbTextCompare
    For Each Dn In Rng
       TwDn = Dn & Dn.Offset(, 3) & Dn.Offset(, 4)
       If Not .Exists(TwDn) Then
            C = C + 1
            For BLK = 0 To 9
                Ray(C, BLK + 1) = Dn.Offset(, BLK)
            Next BLK
              .Add TwDn, ""
        Else
                C = C + 1
            For BLK = 1 To 5
                Ray(C, BLK) = ""
            Next BLK
        End If
    Next Dn
End With
Range("L1").Resize(Rng.Count, 10) = Ray
 
  End Sub

Regards Mick