Search value in array and color if meats conditions

[pupsia]

Hello all!

I`m trying to write a macro that goes through all cell in AQ column, splits information in every cell into array and if conditions are met, color the cell.

[TABLE="width: 500"]
<tbody>[TR]
[TD]#[/TD]
[TD]AQ COLUMN[/TD]
[/TR]
[TR]
[TD]1 line[/TD]
[TD]Email Address[/TD]
[/TR]
[TR]
[TD]2 line[/TD]
[TD]Name Surname; Name.Surname@email.com;[/TD]
[/TR]
[TR]
[TD]3 line[/TD]
[TD]Name Surname; Surname@email.com; Surname@email.com[/TD]
[/TR]
[TR]
[TD]4 line[/TD]
[TD]NameSurname; Name.Surname@email.com[/TD]
[/TR]
[TR]
[TD]5 line[/TD]
[TD]Name.Surname@email.com[/TD]
[/TR]
[TR]
[TD]6 line[/TD]
[TD]Name Surname; [/TD]
[/TR]
[TR]
[TD]7 line[/TD]
[TD]Name Surname[/TD]
[/TR]
[TR]
[TD]8 line[/TD]
[TD]Name.Surname@email.com; Name.Surname@email.com[/TD]
[/TR]
[TR]
[TD]9 line[/TD]
[TD]Name.Surname@email.com;Name.Surname@email.com[/TD]
[/TR]
[TR]
[TD]10 line[/TD]
[TD]Name.Surname@email.com; Name.Surname@email.com;[/TD]
[/TR]
[TR]
[TD]11 line[/TD]
[TD]Surname@email.com; Name Surname; Surname@email.com[/TD]
[/TR]
[TR]
[TD]12 line[/TD]
[TD]Name.Surname@email..com[/TD]
[/TR]
[TR]
[TD]13 line[/TD]
[TD][/TD]
[/TR]
[TR]
[TD]14 line[/TD]
[TD]NameSurname; Name.Surname@email.com[/TD]
[/TR]
[TR]
[TD]15 line[/TD]
[TD]Name.Surname@email.com[/TD]
[/TR]
</tbody>[/TABLE]

[TABLE="width: 474"]
<colgroup><col></colgroup><tbody>[TR]
[TD]
The code I`m using is below. No errors pop up. But nothing is colored.

This macro should find some bad cells in the table above.
The lines that should be colored are: 2, 3, 4, 6, 7, 11, 12, 14

Any ideas where I made a mistake? Please help!

Sub Test_Test_Test_Test_Test()

    Dim r As Range
    Dim h As Integer
    Dim j As Integer
    Dim ar() As String


Set WB = ThisWorkbook.Worksheets("Bulk")


    With WB
        LastRow = .Cells(.Rows.Count, "AQ").End(xlUp).Row
    End With


    Set r = WB.Range("AQ" & LastRow)
    
For h = 2 To LastRow


    If WB.Range("AQ" & h).Value <> "" Then: GoTo home


    ar = Split(WB.Range("AQ" & h).Value, ";")


    If UBound(ar) >= 0 Then
        For j = 0 To UBound(ar)
            If ar(j) Like "*..*" Then WB.Range("AQ" & h).Interior.ColorIndex = 45
            If Not ar(j) Like "*@*" Then WB.Range("AQ" & h).Interior.ColorIndex = 45
            If Not ar(j) Like "*.*" Then WB.Range("AQ" & h).Interior.ColorIndex = 45
        Next
    End If


home:
Next




End Sub

[/TD]
[/TR]
</tbody>[/TABLE]

 

[JackDanIce]

Untested, try:

Sub Test()
    
    Dim a() As String
    Dim r   As Range
    Dim LR  As Long
    Dim x   As Long
    
    Const DELIM As String = ";"
    
    Application.ScreenUpdating = False
        
    With Sheets("Bulk")
        If .AutoFilterMode Then .AutoFilterMode = False
        LR = .Cells(.Rows.count, 43).End(xlUp).row
        .Cells(1, 43).Resize(LR).AutoFilter Field:=1, Criteria1:="="
        For Each r In .Cells(1, 43).Resize(LR).SpecialCells(xlCellTypeVisible)
            a = Split(r.Value, DELIM)
            For x = LBound(a) To UBound(a)
                If InStr(a(x), "..") Or InStr(a(x), "@") Or InStr(a(x), ".") Then Rng.Interior.ColorIndex = 45
            Next x
            Erase a
        Next r
        .AutoFilterMode = False
    End With
            
    Application.ScreenUpdating = True
    
End Sub

 

[pupsia]

JackDanIce, thank you for your response Not sure why, but nothing is happening for some reason

After a while I changed one line and now is seems to work, more or less.

If WB.Range("AQ" & h).Value = "" Then: GoTo home

Thank you for your help!

 

[JackDanIce]

You do not need that line at all, can you post the code that is working for you?

This line should field column number 43 (AQ) for values that are blank

.Cells(1, 43).Resize(LR).AutoFilter Field:=1, Criteria1:="="

For none blanks, change code to:

.Cells(1, 43).Resize(LR).AutoFilter Field:=1, Criteria1:="<>"