Do Until loop not working..

[VBABEGINER]

Can any one please help me to correct the do until loop...it is not working...

Please..

Do Until j = Range("Z" & Rows.Count).End(xlUp).Row

str = Range("Z" & j).Value

Set Fndtx = Range("AA2", Cells(LastRow, lastColumn)).Find(What:=str, After:=Range("AA2"), _
LookIn:=xlFormulas, LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False)

If Not Fndtx Is Nothing Then
p = Right(Fndtx.Address, 2)
Range("A" & p).Interior.Color = vbGreen
End If


j = j + 1
Loop

 

[VBABEGINER]

You
are
an
Excellent...!!

Mind blowing solution...Thank You so so much for your patience again and solution..

Try

Sub test()

    Dim Fnd As Long
    Dim Cl As Range
    Dim Cnt As Long
    Dim Fndtx As Range
    Dim LastRow As Long
    Dim LastCol As Long
    Dim NxtFnd As Range


Application.ScreenUpdating = False
Application.DisplayAlerts = False


    Range("A2", Range("A2").End(xlDown)).Copy Range("AA2")
    
    Range("AA2", Range("AA2").End(xlDown)).TextToColumns Destination:=Range("AA2"), DataType:=xlDelimited, _
    TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=True, Tab:=False, _
    Semicolon:=False, Comma:=False, Space:=True, Other:=False, FieldInfo _
    :=Array(Array(1, 1), Array(2, 1), Array(3, 1), Array(4, 1), Array(5, 1)), _
    TrailingMinusNumbers:=True
    
    LastCol = ActiveSheet.Cells.SpecialCells(xlLastCell).Column
    LastRow = Cells(Rows.Count, "AA").End(xlUp).Row
    
    Set Fndtx = Range("AA2")
    For Each Cl In Range("Z2", Range("Z" & Rows.Count).End(xlUp))
        Cnt = WorksheetFunction.Countif(Range("AA2", Cells(LastRow, LastCol)), Cl.Value)
        If Cnt > 0 Then
            For Fnd = 1 To Cnt
                Set Fndtx = Range("AA2", Cells(LastRow, LastCol)).Find(What:=Cl.Value, After:=Fndtx, _
                LookIn:=xlValues, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
                MatchCase:=False, SearchFormat:=False)
                Range("A" & Fndtx.Row).Interior.Color = vbGreen
            Next Fnd
        End If
    Next Cl
    
    Range(Cells(1, 27), Cells(1, LastCol)).EntireColumn.Delete Shift:=xlToLeft
    Range("A1").Select

Application.DisplayAlerts = True
Application.ScreenUpdating = True


End Sub

 

[Fluff]

Glad to help & thanks for the feedback

 

[VBABEGINER]

Glad to help & thanks for the feedback

Hi Fluff and All the team member's,
Apologies to interrupt once again on the query..


As I said, In Col Z, there are Unique Codes / text..like

ABC
PQR
XYZ
FAN
PARIS

For this it perfectly highlighting the data in Col A.

But there is a problem now...
There are more unique words in the Col Z, like

ABC
PQR
XYZ
PARIS
DO POLICY CONDITION
NORTH AMERICA

for this, DO POLICY CONDITION and NORTH AMERICA are difficult to highlight. These values are in single cell of Col Z. Therefore, they are not matching with data which segregated after AA Col.

So How can I do the highlight for this names....any idea..

 

[VBABEGINER]

Hi Fluff,

Need a small help from you...generally what happens when I try to write a code, so it is basically similar Or I take / refer from recording macro..and then do some changes.

What I have noticed, in your coding method guys, you have awesome idea, tricks, method in your code. really dont understand, from where u hav learn this all..To do the coding, is Ok...

But the way you write the code Guys was pretty awesome...
example..

Range("A2", Range("A2").End(xlDown)).Copy Range("AA2")

can u please suggest ur coding method from where to learn or grab ?? please..

 

[Fluff]

I missed your post yesterday, but with this mod to the code if the Value in Z contains a space it will search col A for the value rather than Cols AA onwards

Sub test()

    Dim Fnd As Long
    Dim Cl As Range
    Dim Cnt As Long
    Dim Fndtx As Range
    Dim LastRow As Long
    Dim LastCol As Long
    Dim NxtFnd As Range
    Dim SrchRng As Range


Application.ScreenUpdating = False
Application.DisplayAlerts = False


    Range("A2", Range("A2").End(xlDown)).Copy Range("AA2")
    
    Range("AA2", Range("AA2").End(xlDown)).TextToColumns Destination:=Range("AA2"), DataType:=xlDelimited, _
    TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=True, Tab:=False, _
    Semicolon:=False, Comma:=False, Space:=True, Other:=False, FieldInfo _
    :=Array(Array(1, 1), Array(2, 1), Array(3, 1), Array(4, 1), Array(5, 1)), _
    TrailingMinusNumbers:=True
    
    LastCol = ActiveSheet.Cells.SpecialCells(xlLastCell).Column
    LastRow = Cells(Rows.Count, "AA").End(xlUp).Row
    
    For Each Cl In Range("Z2", Range("Z" & Rows.Count).End(xlUp))
        If Not InStr(1, Cl.Value, " ") > 0 Then
            Set SrchRng = Range("AA2", Cells(LastRow, LastCol))
        Else
            Set SrchRng = Range("A2", Range("A2").End(xlDown))
        End If
        Set Fndtx = SrchRng.Cells(1, 1)
        Cnt = WorksheetFunction.Countif(SrchRng, Cl.Value)
        If Cnt > 0 Then
            For Fnd = 1 To Cnt
                Set Fndtx = SrchRng.Find(What:=Cl.Value, After:=Fndtx, _
                LookIn:=xlValues, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
                MatchCase:=False, SearchFormat:=False)
                Range("A" & Fndtx.Row).Interior.Color = vbGreen
            Next Fnd
        End If
    Next Cl
    
    Range(Cells(1, 27), Cells(1, LastCol)).EntireColumn.Delete shift:=xlToLeft
    Range("A1").Select

Application.DisplayAlerts = True
Application.ScreenUpdating = True


End Sub

As for learning the different ways of coding things, most of what I've learned has been from reading posts on this site, along with helping others.

 

[VBABEGINER]

Hi Fluff,

Need one help..Is this line of code is true?

Set SrchRng = Range("A2", Range("A2").End(xlDown))

 

[Fluff]

Not quite sure what you mean, but that line of code sets the range from A2 to the first blank cell below A2.
So if A100 was blank, the SrchRng would be A2:A99

 

[VBABEGINER]

Not quite sure what you mean, but that line of code sets the range from A2 to the first blank cell below A2.
So if A100 was blank, the SrchRng would be A2:A99

Ok. Let me cross-check some
..Reason to ask, Codes which are available in Col Z and correctly find out in Col A, but not entire code highlight.
..eg.- AI code. Finding and Coloring in Col A at 3 place, but 2 are more there which are not get's highlight. That's only the concern.

 

[VBABEGINER]

Apart to this, Fluff can you also help me in..one more code added in Col Z. i.e. Exe
If this founds after AA, then respective row gets Colored in Col A. But colored should to text, RED. Is it possible to do please..

 

[Fluff]

Try this

Sub test()

    Dim Fnd As Long
    Dim Cl As Range
    Dim Cnt As Long
    Dim Fndtx As Range
    Dim LastRow As Long
    Dim LastCol As Long
    Dim NxtFnd As Range
    Dim SrchRng As Range


Application.ScreenUpdating = False
Application.DisplayAlerts = False


    Range("A2", Range("A2").End(xlDown)).Copy Range("AA2")
    
    Range("AA2", Range("AA2").End(xlDown)).TextToColumns Destination:=Range("AA2"), DataType:=xlDelimited, _
    TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=True, Tab:=False, _
    Semicolon:=False, Comma:=False, Space:=True, Other:=False, FieldInfo _
    :=Array(Array(1, 1), Array(2, 1), Array(3, 1), Array(4, 1), Array(5, 1)), _
    TrailingMinusNumbers:=True
    
    LastCol = ActiveSheet.Cells.SpecialCells(xlLastCell).Column
    LastRow = Cells(Rows.Count, "AA").End(xlUp).Row
    
    For Each Cl In Range("Z2", Range("Z" & Rows.Count).End(xlUp))
        If Not InStr(1, Cl.Value, " ") > 0 Then
            Set SrchRng = Range("AA2", Cells(LastRow, LastCol))
        Else
            Set SrchRng = Range("A2", Range("A2").End(xlDown))
        End If
        Set Fndtx = SrchRng.Cells(1, 1)
        Cnt = WorksheetFunction.Countif(SrchRng, Cl.Value)
        If Cnt > 0 Then
            For Fnd = 1 To Cnt
                Set Fndtx = SrchRng.Find(What:=Cl.Value, After:=Fndtx, _
                LookIn:=xlValues, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
                MatchCase:=False, SearchFormat:=False)
                If LCase(Cl.Value) = "exe" Then
                    Range("A" & Fndtx.Row).Interior.Color = vbRed
                Else
                    Range("A" & Fndtx.Row).Interior.Color = vbGreen
                End If
            Next Fnd
        End If
    Next Cl
    
    Range(Cells(1, 27), Cells(1, LastCol)).EntireColumn.Delete shift:=xlToLeft
    Range("A1").Select

Application.DisplayAlerts = True
Application.ScreenUpdating = True


End Sub