This code to run over multiple columns

[Pumper]

Hi All, I have this code that Peter_SSs kindly provided that works perfectly.

I would like to expand this code to run over each column if row 1 in that column has something in it.

So once it has run over column A move on to column B etc until there is nothing in row 1 of whatever column that may be.

Have tried to get this to work via a loop but no bueno, here is the code that works on column A

Any assistance would be much appreciated

Sub Remove_Based_on_Right9()
Sheets("Sheet1").Select
  With Range("A2", Range("A" & Rows.Count).End(xlUp))
    .Value = Evaluate(Replace("if(isnumber(match(""*""&left(right(#,9),1)&""*"",A1,0)),#,0)", "#", .Address))
    On Error Resume Next
    .SpecialCells(xlConstants, xlNumbers).Delete Shift:=xlUp
    On Error GoTo 0
  End With
End Sub

 

[kvsrinivasamurthy]

Is X is the 9th Letter from left. I feel it's from right.

 

[Pumper]

Is X is the 9th Letter from left. I feel it's from right.

yeah sorry from the right

 

[Alex Blakenburg]

Your sample results for column B look wrong, it contains V & X which are not in B1.

This is a bit long winded but give it a try.

Sub Remove_Based_on_Right9_v02()

    Dim sht As Worksheet
    Dim rngHdg As Range, rngData As Range
    Dim strFormula As String
    Dim i As Long, lastCol As Long, lastRow As Long
   
    Set sht = Worksheets("Sheet1")
    With sht
        lastCol = .Cells(1, Columns.Count).End(xlToLeft).Column
       
        For i = 1 To lastCol
            Set rngHdg = .Cells(1, i)
            lastRow = .Cells(Rows.Count, i).End(xlUp).Row
           
            If rngHdg.Value <> "" And lastRow <> 1 Then
                Set rngData = .Range(.Cells(2, i), .Cells(lastRow, i))
                With rngData
                    strFormula = "if(isnumber(match(""*""&left(right(#,9),1)&""*"",A1,0)),#,0)"
                    strFormula = Replace(strFormula, "#", .Address)
                    strFormula = Replace(strFormula, "A1", rngHdg.Address(0, 0))
                    Debug.Print strFormula
                    .Value = Evaluate(strFormula)
                    On Error Resume Next
                    .SpecialCells(xlConstants, xlNumbers).Delete Shift:=xlUp
                    On Error GoTo 0
                End With
            End If
        Next i
    End With
End Sub

In case it helps anyone else here is an XL2BB of the test data:

20240911 VBA Loop through columns Pumper.xlsm
	A	B
1	F,J,N,V	H,M,U,Z
2	PLV4 Tester	PAU4 Tester
3	PLF5 Tester	PAV4 Tester
4	PLJ5 Tester	PAX4 Tester
5	PLN5 Tester	PAZ4 Tester
6	PLV5 Tester	PAH5 Tester
7	PLF6 Tester	PAM5 Tester
8	PLJ6 Tester	PAU5 Tester
9	PLN6 Tester	PAZ5 Tester
10	PLV6 Tester	PAH6 Tester
11	PLF7 Tester	PAM6 Tester
12	PLJ7 Tester	PAU6 Tester
13	PLN7 Tester	PAZ6 Tester
14	PLX7 Tester	PAH7 Tester
15		PAM7 Tester
16		PAX7 Tester
Sheet1 (2)

 

[Pumper]

Your sample results for column B look wrong, it contains V & X which are not in B1.

This is a bit long winded but give it a try.

Sub Remove_Based_on_Right9_v02()

    Dim sht As Worksheet
    Dim rngHdg As Range, rngData As Range
    Dim strFormula As String
    Dim i As Long, lastCol As Long, lastRow As Long
  
    Set sht = Worksheets("Sheet1")
    With sht
        lastCol = .Cells(1, Columns.Count).End(xlToLeft).Column
      
        For i = 1 To lastCol
            Set rngHdg = .Cells(1, i)
            lastRow = .Cells(Rows.Count, i).End(xlUp).Row
          
            If rngHdg.Value <> "" And lastRow <> 1 Then
                Set rngData = .Range(.Cells(2, i), .Cells(lastRow, i))
                With rngData
                    strFormula = "if(isnumber(match(""*""&left(right(#,9),1)&""*"",A1,0)),#,0)"
                    strFormula = Replace(strFormula, "#", .Address)
                    strFormula = Replace(strFormula, "A1", rngHdg.Address(0, 0))
                    Debug.Print strFormula
                    .Value = Evaluate(strFormula)
                    On Error Resume Next
                    .SpecialCells(xlConstants, xlNumbers).Delete Shift:=xlUp
                    On Error GoTo 0
                End With
            End If
        Next i
    End With
End Sub

In case it helps anyone else here is an XL2BB of the test data:

20240911 VBA Loop through columns Pumper.xlsm
	A	B
1	F,J,N,V	H,M,U,Z
2	PLV4 Tester	PAU4 Tester
3	PLF5 Tester	PAV4 Tester
4	PLJ5 Tester	PAX4 Tester
5	PLN5 Tester	PAZ4 Tester
6	PLV5 Tester	PAH5 Tester
7	PLF6 Tester	PAM5 Tester
8	PLJ6 Tester	PAU5 Tester
9	PLN6 Tester	PAZ5 Tester
10	PLV6 Tester	PAH6 Tester
11	PLF7 Tester	PAM6 Tester
12	PLJ7 Tester	PAU6 Tester
13	PLN7 Tester	PAZ6 Tester
14	PLX7 Tester	PAH7 Tester
15		PAM7 Tester
16		PAX7 Tester
Sheet1 (2)

Sorry on the test results, you are correct.

Your code worked too! ran pretty quickly so no issues there.

Thank you very much for taking the time to look at this

 

[Alex Blakenburg]

Thanks for the feedback. Glad that we could help.

 

[kvsrinivasamurthy]

Try.

Sub Remove_Based_on_Right9()
Dim Clms&, Lr&, T&, k, z$
Dim Rng As Range
Sheets("Sheet1").Select
Set Rng = Range("A:F")  'Select the column(here it is F) as required
Clms = Rng.Columns.Count
 
  For T = 1 To Clms
    Lr = Cells(Rows.Count, T).End(xlUp).Row
    With Range(Cells(2, T), Cells(Lr, T))
    z = .Address
    k = Cells(1, T).Address
        If k <> "" Then
        .Value = Evaluate("if(isnumber(match(""*""&left(right(" & z & ",9),1)&""*""," & k & ",0))," & z & ","""")")
        On Error Resume Next
        .SpecialCells(xlCellTypeBlanks).Delete Shift:=xlUp
        On Error GoTo 0
        End If
    End With
  Next T
End Sub

 

[Pumper]

Try.

Sub Remove_Based_on_Right9()
Dim Clms&, Lr&, T&, k, z$
Dim Rng As Range
Sheets("Sheet1").Select
Set Rng = Range("A:F")  'Select the column(here it is F) as required
Clms = Rng.Columns.Count
 
  For T = 1 To Clms
    Lr = Cells(Rows.Count, T).End(xlUp).Row
    With Range(Cells(2, T), Cells(Lr, T))
    z = .Address
    k = Cells(1, T).Address
        If k <> "" Then
        .Value = Evaluate("if(isnumber(match(""*""&left(right(" & z & ",9),1)&""*""," & k & ",0))," & z & ","""")")
        On Error Resume Next
        .SpecialCells(xlCellTypeBlanks).Delete Shift:=xlUp
        On Error GoTo 0
        End If
    End With
  Next T
End Sub

Hi, sorry late reply, must be in different time zones.

Nice job this works!

Thanks for coming back multiple times to crack this, very kind