Updating Code1

Brew

Well-known Member
Joined
Sep 29, 2003
Messages
1,569
Hello, how do I update the following code:

This one only delete the Yellow Combos when 2 number within the combos are the same and not all different:
example: 006, 606 [DELETE], 312 [NO ACTION]
Code:
Sub DeleteYellowCombos()
 For i = 5 To 804
  If Cells(i, "C") <> Cells(i, "D") And Cells(i, "C") <> Cells(i, "E") And Cells(i, "D") <> Cells(i, "E") Then
    If Abs(Cells(i, "C").Interior.ColorIndex = 6) + Abs(Cells(i, "D").Interior.ColorIndex = 6) + Abs(Cells(i, "E").Interior.ColorIndex = 6) > 1 Then
      Cells(i, "C").Resize(, 3).ClearContents
    End If
  End If
 Next i
End Sub
 

Brew

Well-known Member
Joined
Sep 29, 2003
Messages
1,569
Yes, that is it...Thank you.....I have another code that operate the same way for red combos. How do i update this code to eliminate if the combination has any duplicates. thanks
This one only delete the Red Combos when 2 number within the combos are the same and not all different:
example: 006, 606 [DELETE], 312 [NO ACTION]

Sub DeleteRedCombos()
Dim Cnt As Integer, LastRow As Integer
LastRow = Sheets("sheet5").Cells(Rows.Count, "C").End(xlUp).Row
Do While Cnt <= LastRow
Cnt = Cnt + 1
If Sheets("sheet5").Cells(Cnt, "C").Interior.ColorIndex = 3 _
And Sheets("sheet5").Cells(Cnt, "D").Interior.ColorIndex = 3 _
And Sheets("sheet5").Cells(Cnt, "E").Interior.ColorIndex = 3 Then
If Sheets("sheet5").Cells(Cnt, "C") <> Sheets("sheet5").Cells(Cnt, "D") _
And Sheets("sheet5").Cells(Cnt, "C") <> Sheets("sheet5").Cells(Cnt, "E") _
And Sheets("sheet5").Cells(Cnt, "D") <> Sheets("sheet5").Cells(Cnt, "E") Then
With Sheets("Sheet5")
.Cells(Cnt, "C").ClearContents
.Cells(Cnt, "D").ClearContents
.Cells(Cnt, "E").ClearContents
End With
End If
End If
Loop
End Sub
[/code]
 

Excel Facts

Can Excel fill bagel flavors?
You can teach Excel a new custom list. Type the list in cells, File, Options, Advanced, Edit Custom Lists, Import, OK

Brew

Well-known Member
Joined
Sep 29, 2003
Messages
1,569
Thanks, I made the updates as shown below, however I got a subscript out of range error for line 3:
LastRow = Sheets("sheet8").Cells(Rows.Count, "C").End(xlUp).Row

Code:
Sub DeleteRedComboDoubles()
Dim Cnt As Integer, LastRow As Integer
LastRow = Sheets("sheet8").Cells(Rows.Count, "C").End(xlUp).Row
Do While Cnt <= LastRow
Cnt = Cnt + 1
If Sheets("sheet8").Cells(Cnt, "C").Interior.ColorIndex = 3 _
And Sheets("sheet8").Cells(Cnt, "D").Interior.ColorIndex = 3 _
And Sheets("sheet8").Cells(Cnt, "E").Interior.ColorIndex = 3 Then
If Sheets("sheet8").Cells(Cnt, "C") = Sheets("sheet8").Cells(Cnt, "D") _
Or Sheets("sheet8").Cells(Cnt, "C") = Sheets("sheet8").Cells(Cnt, "E") _
Or Sheets("sheet8").Cells(Cnt, "D") = Sheets("sheet8").Cells(Cnt, "E") Then
With Sheets("Sheet8")
    .Cells(Cnt, "C").ClearContents
    .Cells(Cnt, "D").ClearContents
    .Cells(Cnt, "E").ClearContents
End With
End If
End If
Loop
End Sub
[/code]
 

Forum statistics

Threads
1,148,367
Messages
5,746,283
Members
424,006
Latest member
Metal_warrior

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Top