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
 

Excel Facts

Which Excel functions can ignore hidden rows?
The SUBTOTAL and AGGREGATE functions ignore hidden rows. AGGREGATE can also exclude error cells and more.

Brew

Well-known Member
Joined
Sep 29, 2003
Messages
1,569
Yes exactly, Also, only 2 of the 3 numbers in the combo will have a yellow background.
 

jindon

MrExcel MVP
Joined
Aug 21, 2004
Messages
16,995
See if this works
Code:
Sub DeleteYellowCombos()
Dim i As Long, ii As Long, dic As Object, a() As Integer, mItem As Object, m As Object
Set dic = createObject("Scripting.Dictionary")
ReDim a(2)
 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
       For ii = 3 To 5
       With CreateObject("VBScript.RegExp")
             .Pattern = "\d"
             .Global = True
             Set mItem = .execute(Cells(i,ii).Text)
                 For Each m In mItem
                     If Not dic.exists(m.Value) Then
                         dic.Add m.Value, Nothing
                     Else
                         a(ii-3) = 1
                     End If
                 Next
        End With
        dic.removeall
        Next
        msgbox join(a,",")
        If Application.Sum(a) = 3 Then Cells(i, "C").Resize(, 3).ClearContents
        ReDim a(2)
    End If
  End If
 Next i
End Sub
 

Brew

Well-known Member
Joined
Sep 29, 2003
Messages
1,569
There are no errors, however, it did not delete duplicate entries associated with yellow background.
 

jindon

MrExcel MVP
Joined
Aug 21, 2004
Messages
16,995

ADVERTISEMENT

dk

Can you fo the following for me?
Code:
1) copy the code again (I just added 1 msgbox)
2) type in 

      C5       D5      E5
     112      223     335
    and delete other data
3) Then run the code

Then can you come back with the msgbox?
 

Brew

Well-known Member
Joined
Sep 29, 2003
Messages
1,569
I copy the code again from the edited version, but I dont understand step 2, what do you want me to do there
 

jindon

MrExcel MVP
Joined
Aug 21, 2004
Messages
16,995

ADVERTISEMENT

I want you to type in each cell
c5 : 112, d5:223 e5:335
just a dummy record to test
and also color the cell in yellow
 

Brew

Well-known Member
Joined
Sep 29, 2003
Messages
1,569
my records have only one digit in each cell, so using your example, i could have c5:e5=112, c6:e6=223 and c7:e7=335. Is that what you want me to do or do we need to update the code again
 

jindon

MrExcel MVP
Joined
Aug 21, 2004
Messages
16,995
my records have only one digit in each cell, so using your example, i could have c5:e5=112, c6:e6=223 and c7:e7=335. Is that what you want me to do or do we need to update the code again

Ah, now I understand..

I thought each cell has like 112,223,334 etc...
 

jindon

MrExcel MVP
Joined
Aug 21, 2004
Messages
16,995
like this?
Code:
Sub DeleteYellowCombos()
 For i = 5 To 804
  If Cells(i, "C") = Cells(i, "D") Or Cells(i, "C") = Cells(i, "E") Or 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
 

Forum statistics

Threads
1,148,371
Messages
5,746,308
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