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]

Amazing....Hat's Off to you...!!

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

 

[Fluff]

Glad to help & thanks for the feedback

 

[VBABEGINER]

Pls teach me vba....

 

[VBABEGINER]

Glad to help & thanks for the feedback

can you assist me in this one...this is some what tricky...I dont understand..

https://www.mrexcel.com/forum/excel-questions/1029632-show-image-formula-using-if-condition.html

 

[VBABEGINER]

H Fluff,

I have one problem in this...

Problem is that -
range A3
IN
range A4
abc in pqr

Code separates this in Range AA3, AA4, AA5...and so on..

Unique list I kept in Col Z501 onward. In my unique list, I have "IN" keyword.

but in our line code

Cnt = WorksheetFunction.CountIf(Range("AA3", Cells(LastRow, LastCol)), Cl.Value)

"Cl.Value" read "in" & "IN" same. And hence both lines colored green in Col A.

Could we do something for this, please...

I will share the updated code also...in next post..

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

 

[VBABEGINER]

Updated last code we worked..

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("A3", Range("A3").End(xlDown)).Copy Range("AA3")


Range("AA3", Range("AA3").End(xlDown)).TextToColumns Destination:=Range("AA3"), 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("AA3")
For Each Cl In Range("Z501", Range("Z" & Rows.Count).End(xlUp))
Cnt = WorksheetFunction.CountIf(Range("AA3", Cells(LastRow, LastCol)), Cl.Value)
If Cnt > 0 Then
For Fnd = 1 To Cnt
Set Fndtx = Range("AA3", Cells(LastRow, LastCol)).Find(What:=Cl.Value, After:=Fndtx, _
LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False)

'' If LCase(Cl.Value) = "Exclusion" Then
'' Range("A" & Fndtx.Row).Font.Color = vbRed
'' Else
'' Range("A" & Fndtx.Row).Interior.Color = vbGreen
'' End If

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


Range("A2", Range("C500").End(xlDown)).Copy
Dim wb As Workbook
Set wb = Workbooks.Add
ActiveSheet.Paste
Application.CutCopyMode = False
Columns("A:C").EntireColumn.AutoFit
Cells(1, 1).Select
Application.DisplayAlerts = True
Application.ScreenUpdating = True




End Sub

 

[Fluff]

Unfortunately countif, is not case sensitive.
To differentiate between in and IN would need an array formula, which is out of my league.

 

[VBABEGINER]

Hi Fluff,

Thank you so much for kind revert. Appreciate your presence. I have added If condition and it works. Let me show you.

If Fndtx.Value = "in" Or Fndtx.Value = "or" Then
Else
Range("A" & Fndtx.Row).Interior.Color = vbGreen
End If

Unfortunately countif, is not case sensitive.
To differentiate between in and IN would need an array formula, which is out of my league.

 

[VBABEGINER]

Hey Fluff,
Need your one help please..

 

[VBABEGINER]

Code I have modified in this way, Please look at carefully..

'Range("A3", Range("A3").End(xlDown)).Copy Range("AA3")
Range(Range("A3"), Range("A3").End(xlDown)).Copy
Range("AA3").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Application.CutCopyMode = False

Range("AA3", Range("AA3").End(xlDown)).TextToColumns Destination:=Range("AA3"), 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


Range("AA3", Cells(LastRow, LastCol)).Select
Selection.Copy
Range("AA3").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False

Set Fndtx = Range("AA3")
....
....

If you look at here...previously we copy and paste simple...

'Range("A3", Range("A3").End(xlDown)).Copy Range("AA3")

now im using this..

'Range("A3", Range("A3").End(xlDown)).Copy Range("AA3")

Range(Range("A3"), Range("A3").End(xlDown)).Copy
Range("AA3").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Application.CutCopyMode = False

The reason b'coz, I have added one unique code in Col Z 501 onward. i.e. "-Europe".

Initially, I was facing problem with copy and paste, but I use paste special code...which I just show you above.

That got resolved now.

Now, the problem is, when the below line code is coming to execute-

Range("AA3", Range("AA3").End(xlDown)).TextToColumns Destination:=Range("AA3"), 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

This value "-Europe" is displayed like this "#NAME?"

So can we do for this, to fix. If it is coming properly after Col AA that is in single single cell value, then our code work good...

Can you please guide...