VBA - Remove Duplicates + Sort Data

[hrayani]

Hello Friends,

Here is the sample data

	[COLOR=[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=FFFFFF]#FFFFFF[/URL] ]A[/COLOR]​	[COLOR=[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=FFFFFF]#FFFFFF[/URL] ]B[/COLOR]​	[COLOR=[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=FFFFFF]#FFFFFF[/URL] ]C[/COLOR]​	[COLOR=[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=FFFFFF]#FFFFFF[/URL] ]D[/COLOR]​	[COLOR=[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=FFFFFF]#FFFFFF[/URL] ]E[/COLOR]​	[COLOR=[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=FFFFFF]#FFFFFF[/URL] ]F[/COLOR]​	[COLOR=[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=FFFFFF]#FFFFFF[/URL] ]G[/COLOR]​	[COLOR=[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=FFFFFF]#FFFFFF[/URL] ]H[/COLOR]​	[COLOR=[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=FFFFFF]#FFFFFF[/URL] ]I[/COLOR]​	[COLOR=[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=FFFFFF]#FFFFFF[/URL] ]J[/COLOR]​
[COLOR=[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=FFFFFF]#FFFFFF[/URL] ]1[/COLOR]​
[COLOR=[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=FFFFFF]#FFFFFF[/URL] ]2[/COLOR]​	5​	5​	5​	5​	5​	5​	5​	5​	5​	5​
[COLOR=[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=FFFFFF]#FFFFFF[/URL] ]3[/COLOR]​	Article # 1​	Article # 2​	Article # 3​	Article # 4​	Article # 5​	Article # 6​	Article # 7​	Article # 8​	Article # 9​	Article # 10​
[COLOR=[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=FFFFFF]#FFFFFF[/URL] ]4[/COLOR]​	1​	256​	25​	256​	256​	256​	256​	256​	256​	256​
[COLOR=[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=FFFFFF]#FFFFFF[/URL] ]5[/COLOR]​	2​	265​	256​	265​	265​	901​	289​	369​	289​	369​
[COLOR=[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=FFFFFF]#FFFFFF[/URL] ]6[/COLOR]​	10​	298​	265​	289​	289​	925​	298​	901​	298​	901​
[COLOR=[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=FFFFFF]#FFFFFF[/URL] ]7[/COLOR]​	256​	1237​	298​	298​	298​	987​	365​	925​	365​	925​
[COLOR=[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=FFFFFF]#FFFFFF[/URL] ]8[/COLOR]​	289​	2365​	1237​	365​	365​	2365​	369​	936​	369​	936​

<tbody>
</tbody>

Worksheet Formulas Cell Formula A2 =COUNTA(A4:A1000) <tbody> </tbody>

<tbody>
</tbody>

I am using below macros to remove duplicates and sort data

Sub removeduplicates()

  ActiveSheet.Range("A4:B1000").removeduplicates Columns:=1, Header:=xlNo
  ActiveSheet.Range("B4:B1000").removeduplicates Columns:=1, Header:=xlNo
  ActiveSheet.Range("C4:C1000").removeduplicates Columns:=1, Header:=xlNo
  ActiveSheet.Range("D4:D1000").removeduplicates Columns:=1, Header:=xlNo
  ActiveSheet.Range("E4:E1000").removeduplicates Columns:=1, Header:=xlNo
  ActiveSheet.Range("F4:F1000").removeduplicates Columns:=1, Header:=xlNo
  ActiveSheet.Range("G4:G1000").removeduplicates Columns:=1, Header:=xlNo
  ActiveSheet.Range("H4:H1000").removeduplicates Columns:=1, Header:=xlNo
  ActiveSheet.Range("I4:I1000").removeduplicates Columns:=1, Header:=xlNo
  ActiveSheet.Range("J4:J1000").removeduplicates Columns:=1, Header:=xlNo
  
End Sub

Sub sort()    
    Range("A4:A1000").sort Key1:=Range("A4"), Order1:=xlAscending, Header:=xlNo
    Range("B4:B1000").sort Key1:=Range("B4"), Order1:=xlAscending, Header:=xlNo
    Range("C4:C1000").sort Key1:=Range("C4"), Order1:=xlAscending, Header:=xlNo
    Range("D4:D1000").sort Key1:=Range("D4"), Order1:=xlAscending, Header:=xlNo
    Range("E4:E1000").sort Key1:=Range("E4"), Order1:=xlAscending, Header:=xlNo
    Range("F4:F1000").sort Key1:=Range("F4"), Order1:=xlAscending, Header:=xlNo
    Range("G4:G1000").sort Key1:=Range("G4"), Order1:=xlAscending, Header:=xlNo
    Range("H4:H1000").sort Key1:=Range("H4"), Order1:=xlAscending, Header:=xlNo
    Range("I4:I1000").sort Key1:=Range("I4"), Order1:=xlAscending, Header:=xlNo
    Range("J4:J1000").sort Key1:=Range("J4"), Order1:=xlAscending, Header:=xlNo
    
End Sub

Is there a better way to write the macro.

Further I would like following 2 conditions if possible for both macros.

1) Starting from row # 4 look at the last used cell in each column rather than define range in macro
2) Both macros should remove data & sort data only if more than 8 cells have data in there.

Any help would be appreciated.

Regards,

Humayun

 

[hrayani]

Does the formula in row 2 show the correct number of values for each column?

Yes dear

 

[Fluff]

In that case if any column is empty, row2 should show 0 & this line

If Cells(2, i) > 8 Then

should then skip that column.

 

[hrayani]

Got it.

I later changed the formula from

This
COUNTA(A4:A1000)

To
=IF(COUNTA(A4:A1000)=0,"0",COUNTA(A4:A1000))


and this was causing the problem


Now i will stick to the previous formula

All working fine now..


Thanks for you help as always.

Regards,

 

[Fluff]

Glad you sorted it & thanks for the feedback

 

[hrayani]

Hi Fluff,

One more thing but with different data format - if possible

Excel 2016 (Windows) 64 bit

	A​	B​	C​	D​	E​	F​	G​	H​	I​	J​	K​	L​	M​	N​	O​	P​	Q​	R​	S​	T​	U​	V​	W​	X​
1​	SIZE WEIGHT - TOTAL PIECES CHECKED > 54​	​	​	​	​	​	​	​	​	​	​	​	​	​	​	​	​	​	​	​	​	​	​	​
2​	6​	​	​	48​	​	​	0​	​	​	0​	​	​	0​	​	​	0​	​	​	0​	​	​	0​	​	​
3​	[ Article 1 ]​	​	​	[ Article 2 ]​	​	​	[ Article 3 ]​	​	​	[ Article 4 ]​	​	​	[ Article 5 ]​	​	​	[ Article 6 ]​	​	​	[ Article 7 ]​	​	​	[ Article 8 ]​	​	​
4​	1 x 1​	​	​	2 x 2​	​	​	3 x 3​	​	​	4 x 4​	​	​	5 x 5​	​	​	6 x 6​	​	​	7 x 7​	​	​	8 x 8​	​	​
5​	50​	100​	50 x 100​	50​	101​	50 x 101​	​	​	x​	​	​	x​	​	​	x​	​	​	x​	​	​	x​	​	​	x​
6​	50​	101​	50 x 101​	51​	101​	51 x 101​	​	​	x​	​	​	x​	​	​	x​	​	​	x​	​	​	x​	​	​	x​
7​	50​	102​	50 x 102​	50​	100​	50 x 100​	​	​	x​	​	​	x​	​	​	x​	​	​	x​	​	​	x​	​	​	x​
8​	51​	100​	51 x 100​	50​	102​	50 x 102​	​	​	x​	​	​	x​	​	​	x​	​	​	x​	​	​	x​	​	​	x​
9​	51​	101​	51 x 101​	50​	101​	50 x 101​			x​			x​			x​			x​			x​			x​
10​	51​	102​	51 x 102​	51​	100​	51 x 100​	​	​	x​	​	​	x​	​	​	x​	​	​	x​	​	​	x​	​	​	x​
11​			x​	50​	101​	50 x 101​	​	​	x​	​	​	x​	​	​	x​	​	​	x​	​	​	x​	​	​	x​
12​			x​	50​	100​	50 x 100​	​	​	x​	​	​	x​	​	​	x​	​	​	x​	​	​	x​	​	​	x​
13​			x​	50​	101​	50 x 101​	​	​	x​	​	​	x​	​	​	x​	​	​	x​	​	​	x​	​	​	x​
14​			x​	51​	100​	51 x 100​	​	​	x​	​	​	x​	​	​	x​	​	​	x​	​	​	x​	​	​	x​
15​			x​	50​	102​	50 x 102​	​	​	x​	​	​	x​	​	​	x​	​	​	x​	​	​	x​	​	​	x​

Sheet: SIZE

<tbody></tbody>

In this case I would want the code to look at the Columns C, F, I and so on till Column X to remove duplicates and sort data if more than 8 entries are there in each column.

EDIT:
The table above is so messy. I am not able to paste it properly. I dont know why ?

 

[Fluff]

In that case change the loop to

For i = 3 To 24 Step 3

 

[hrayani]

Changes in red

Sub hrayani()   
   
   Dim i As Long
   
[B][COLOR=#ff0000]   For i = 3 To 24 Step 3 [/COLOR][/B]
      If Cells(2, i) > 8 Then
         With Cells([B][COLOR=#ff0000]5[/COLOR][/B], i).Resize(Cells(2, i))
            .removeduplicates 1, xlNo
            .sort key1:=Cells([B][COLOR=#ff0000]5[/COLOR][/B], i), order1:=xlAscending, Header:=xlNo
         End With
      End If
   Next i
   
   
   
End Sub

Not working.....

In case if the table is not clear.

1) Data Starts from row # 5
2) Formula in C2 =COUNTIF(C5:C1000,"<> x ")
3) Formula in C5 till C100 =A5&" x "&B5
4) Manual entries in cell A5 & B5


EDIT
Please wait

 

[hrayani]

Hi Fluff,

I having following two issues

1) The code is removing duplicates but also deleting formulas from Column C.
As soon as the duplicates are removed and the cells are shifted up - it clears the the cell formula too.

2) Its not sorting data



Can we look at columns A & B to remove duplicates ?

In this way the formula in column C will remain in tact

 

[Fluff]

Using RemoveDuplicates on multiple columns is flaky, so I would advise against doing that.
You could convert the formula to values first, but I don't understand what you are trying to do, as you are only removing the duplicates in individual columns, not the entire data.

 

[hrayani]

Using RemoveDuplicates on multiple columns is flaky, so I would advise against doing that.

Yes, I agree

Here is what I have come up with and the code does exactly what I want to

Sub duplicatesremove()


    If Range("C2").Value > 8 Then
    ActiveSheet.Range("A5:B1000").removeduplicates Columns:=Array(1, 2), Header:=xlNo
    
[B][COLOR=#ff0000]    With ActiveSheet.sort[/COLOR][/B]
[B][COLOR=#ff0000]     .SortFields.Add Key:=Range("A5"), Order:=xlAscending[/COLOR][/B]
[B][COLOR=#ff0000]     .SortFields.Add Key:=Range("B5"), Order:=xlAscending[/COLOR][/B]
[B][COLOR=#ff0000]     .SetRange Range("A5:B1000")[/COLOR][/B]
[B][COLOR=#ff0000]     .Header = xlNo[/COLOR][/B]
[B][COLOR=#ff0000]     .Apply[/COLOR][/B]
[B][COLOR=#ff0000]    [/COLOR][/B]
[B][COLOR=#ff0000]    End With[/COLOR][/B]
    End If
    
    
    If Range("F2").Value > 8 Then
    ActiveSheet.Range("D5:E1000").removeduplicates Columns:=Array(1, 2), Header:=xlNo
    End If
        
        If Range("I2").Value > 8 Then
        ActiveSheet.Range("G5:H1000").removeduplicates Columns:=Array(1, 2), Header:=xlNo
        End If
            
            If Range("L2").Value > 8 Then
            ActiveSheet.Range("J5:K1000").removeduplicates Columns:=Array(1, 2), Header:=xlNo
            End If
                
                If Range("O2").Value > 8 Then
                ActiveSheet.Range("M5:N1000").removeduplicates Columns:=Array(1, 2), Header:=xlNo
                End If
                    
                    If Range("R2").Value > 8 Then
                    ActiveSheet.Range("P5:Q1000").removeduplicates Columns:=Array(1, 2), Header:=xlNo
                    End If
                        
                        If Range("U2").Value > 8 Then
                        ActiveSheet.Range("S5:T1000").removeduplicates Columns:=Array(1, 2), Header:=xlNo
                        End If
                            
                            If Range("X2").Value > 8 Then
                            ActiveSheet.Range("V5:W1000").removeduplicates Columns:=Array(1, 2), Header:=xlNo
                            End If
                      
End Sub

Is there a better what of writing it ? ... I am sure there must be
secondly I want the red part of the code i.e. the sorting after after every set or removing duplicates.

Regards