Macro to delete Row based on criteria?

[mcintoshmc]

Currently I'm using this formula as a conditional format that highlights the entire row if the cell in column A is a duplicate.

=COUNTIF($A:$A,$A2)>1

I already have a macro that will delete the duplicates automatically, and have it as a button on my quick access toolbar.

I've created another forumula

=IF(NOT(OR($H2=List!$A$2,$H2=List!$A$3,$H2=List!$A$4)),"X","")

This will place a X in column P if a certain name is not located in column H.

Ideally, I would like a Macro that would delete the duplicate from column A that also has an X in column P.

This is the current macro I'm using to delete the duplicates

Sub Delete_duplicate_rows()
Dim Rng As Range
Set Rng = Selection
Rng.RemoveDuplicates Columns:=Array(1), Header:=xlYes
End Sub

 

[kevin9999]

Does that mean that you want to keep duplicates that don't have an X in column P?

 

[mcintoshmc]

Does that mean that you want to keep duplicates that don't have an X in column P?

Yes, once the ones with the x are removed, there would be no more duplicates.

 

[kevin9999]

If it's purely a case of deleting all rows that have an "X" in column P, try the following on a copy of your workbook. Change the sheet name to suit.

Option Explicit
Sub mcintosh()
    Application.ScreenUpdating = False
    Dim ws As Worksheet, i As Long
    Set ws = Worksheets("Sheet1")   '<~~ *** Change to actual sheet name ***
    i = WorksheetFunction.CountIf(ws.Range("P:P"), "X")
    If i > 0 Then
        ws.Range("A1").CurrentRegion.Sort Key1:=ws.Range("P2"), _
        order1:=xlAscending, Header:=xlGuess
        ws.Range("A2").Resize(i).EntireRow.Delete
    End If
    Application.ScreenUpdating = True
End Sub

 

[mcintoshmc]

I've come to the conclusion that I can't use the "X" because after the macro sorts and deletes, the formula for X will no longer be in all the required cells.

Perhaps deleting the row based on color will produce better results. So, now column H will contain the color, and those rows that contain green in the H cell will need to be deleted.

I'm using this macro, but doesn't work. Any thoughts?

Sub deleterow()
     Dim myRange As Range
     Dim cell As Range
     
     Application.Calculation = xlCalculationManual
     Set myRange = Worksheets(1).Range("H2:H200")
  For i = myRange.Rows.Count To 1 Step -1
If myRange(i).Interior.ColorIndex = 4 Then
myRange(i).EntireRow.Delete
End If
Next i

     Application.Calculation = xlCalculationAutomatic
End Sub

 

[kevin9999]

Could you provide a copy of your sheet using the XL2BB add in or alternatively, share a copy of your workbook via DropBox, Google Drive or similar file sharing platform?

 

[mcintoshmc]

I can't send over the actual data, but here is a make shift one I created. Essentially, I want the macro to delete all of the green rows.

TEST.xlsm
	A	B	C	D	E	F	G	H	I	J	K	L	M	N	O
1								Collaborator Full Name
2								E
3								A
4								A
5								E
6								A
7								A
8								E
9								A
10								A
11								G
12								A
13								A
14								U
15								A
16								A
17								I
18								A
19								A
20								G
21								A
22								A
23								E
24								A
25								A
26								C
27								A
28								A
29								L
30								A
31								A
32								A
33								A
34								A
35								A
36								A
37								M
38								A
39								A
40								A
41								A
42								A
43								A
44								P
45								B
46								B
47								B
48								B
49								B
50								B
51								A
52								A
53								A
54								A
55								A
56								A
57								A
58								A
59								A
60								A
61								C
62								C
63								C
64								C
65								C
66								C
67								C
68								C
69								A
70								A
71								A
72								A
73								A
74								A
75								A
76								A
77								A
78								A
79								A
80								A
81								A
82								A
83								A
84								A
85								A
86								A
87								A
88								A
89								D
90								D
91								D
92								D
93								D
94								D
95								D
96								D
97								D
Sheet1

Cells with Conditional Formatting
Cell	Condition		Cell Format	Stop If True
H2:H97	Cell Value	not containing "A"	text	NO

 

[mcintoshmc]

Actually, let me give you the original problem. The are duplicate numbers in column A, and I only need 1 row per number. The row I need to keep is the row that contains "A" in column H.

I use this macro to rid myself of the duplicates

Sub Delete_duplicate_rows()
Dim Rng As Range
Set Rng = Selection
Rng.RemoveDuplicates Columns:=Array(1), Header:=xlYes
End Sub

But it will only keep the top number and delete the others. Sometimes that works as A is the top row, but other times it doesn't work.

Any suggestions?

TEST.xlsm
	A	B	C	D	E	F	G	H	I	J	K	L	M	N	O
1	Number							Collaborator Full Name
2	1							E
3	1							A
4	1							B
5	1							E
6	5							A
7	5							B
8	5							E
9	8							A
10	9							A
11	10							G
12	10							A
13	10							B
14	10							U
15	14							A
16	15							A
17	16							A
18	16							B
19	16							C
Sheet1

 

[kevin9999]

If you want to go down the delete by colour path, then try the following (just change the sheet name & RGB colour to match what you've got)

Option Explicit
Sub mcintosh_Delete_By_Colour()
    Dim ws As Worksheet
    Set ws = Worksheets("Sheet1")           '<~~ *** Change sheet name to suit ***
    With ws.Range("H1", ws.Cells(Rows.Count, "H").End(xlUp))
        .AutoFilter 1, RGB(0, 255, 0), 8    '<~~ *** Change RGB number to match your colour ***
        If ws.Cells(Rows.Count, "H").End(xlUp).Row > 1 Then
            .Offset(1).EntireRow.Delete
        End If
        .AutoFilter
    End With
End Sub

Before:

mcintosh.xlsm
	A	B	C	D	E	F	G	H
1								Collaborator Full Name
2								E
3								A
4								A
5								E
6								A
7								A
8								E
9								A
10								A
11								G
12								A
13								A
14								U
15								A
16								A
17								I
18								A
19								A
20								G
21								A
22								A
23								E
24								A
25								A
26								C
27								A
28								A
29								L
30								A
31								A
32								A
33								A
34								A
35								A
36								A
37								M
38								A
39								A
40								A
41								A
42								A
43								A
44								P
45								B
46								B
47								B
48								B
49								B
50								B
51								A
52								A
53								A
54								A
55								A
56								A
57								A
58								A
59								A
60								A
61								C
62								C
63								C
64								C
65								C
66								C
67								C
68								C
69								A
70								A
71								A
72								A
73								A
74								A
75								A
76								A
77								A
78								A
79								A
80								A
81								A
82								A
83								A
84								A
85								A
86								A
87								A
88								A
89								D
90								D
91								D
92								D
93								D
94								D
95								D
96								D
97								D
Sheet1

After:

mcintosh.xlsm
	A	B	C	D	E	F	G	H
1								Collaborator Full Name
2								A
3								A
4								A
5								A
6								A
7								A
8								A
9								A
10								A
11								A
12								A
13								A
14								A
15								A
16								A
17								A
18								A
19								A
20								A
21								A
22								A
23								A
24								A
25								A
26								A
27								A
28								A
29								A
30								A
31								A
32								A
33								A
34								A
35								A
36								A
37								A
38								A
39								A
40								A
41								A
42								A
43								A
44								A
45								A
46								A
47								A
48								A
49								A
50								A
51								A
52								A
53								A
54								A
55								A
56								A
57								A
58								A
59								A
60								A
61								A
62								A
63
Sheet1

Alternatively, if you wanted to delete using the original data - with no reference to the colour - then try this (just change the sheet name to suit)

Option Explicit
Sub mcintosh_Delete_By_Data()
    Dim ws As Worksheet
    Set ws = Worksheets("Sheet2")           '<~~ *** Change sheet name to suit ***
    Dim r As Range, i As Long, a, b As Range
    a = ws.Range("A1", ws.Cells(Rows.Count, "H").End(xlUp))
    Set b = ws.Range("A2", ws.Cells(Rows.Count, "A").End(xlUp))
    
    For i = 2 To UBound(a, 1)
        If WorksheetFunction.CountIf(b, CStr(a(i, 1))) > 1 And a(i, 8) <> "A" Then
            If r Is Nothing Then
                Set r = ws.Cells(i, 1)
            Else
                Set r = Union(r, ws.Cells(i, 1))
            End If
        End If
    Next i
    If Not r Is Nothing Then
        r.EntireRow.Delete
    End If
End Sub

Before:

mcintosh.xlsm
	A	B	C	D	E	F	G	H
1	Number							Collaborator Full Name
2	1							E
3	1							A
4	1							B
5	1							E
6	5							A
7	5							B
8	5							E
9	8							A
10	9							A
11	10							G
12	10							A
13	10							B
14	10							U
15	14							A
16	15							A
17	16							A
18	16							B
19	16							C
20
Sheet2

After:

mcintosh.xlsm
	A	B	C	D	E	F	G	H
1	Number							Collaborator Full Name
2	1							A
3	5							A
4	8							A
5	9							A
6	10							A
7	14							A
8	15							A
9	16							A
10
Sheet2