Delete Cell if 3rd character not equal to...

[Pumper]

Hi All,

I am attempting to run some vba over multiple columns to delete any cell where the 3rd character does not equal any of the letters in Cell 1A.

The length of the original column can vary.

The letters would be different across row 1 for each additional column but I should be able to update the code if I can get the first column to work.

Any assistance/advice on this would be greatly appreciated!

So Original Data for example would be something like this:

The desired outcome would be this:

Thanks

 

[bebo021999]

try this:

Option Explicit
Sub del()
Dim lr&, i&, k&, rng, res()
lr = Cells(Rows.Count, "A").End(xlUp).Row ' last used row of column A
rng = Range("A2:A" & lr).Value  'store data into array
ReDim res(1 To UBound(rng), 1 To 1)
For i = 1 To UBound(rng)
    'search for 3rd letter in cell A1 
    If InStr(1, Cells(1, "A") & ",", Mid(rng(i, 1), 3, 1) & ",") Then ' if found
        k = k + 1: res(k, 1) = rng(i, 1) ' store results into array
    End If
Next
If k > 0 Then
    Range("A2:A1000").ClearContents 'delete previous results
    Range("A2").Resize(k, 1).Value = res ' paste results back to sheet
End If
End Sub

 

[Pumper]

try this:

Option Explicit
Sub del()
Dim lr&, i&, k&, rng, res()
lr = Cells(Rows.Count, "A").End(xlUp).Row ' last used row of column A
rng = Range("A2:A" & lr).Value  'store data into array
ReDim res(1 To UBound(rng), 1 To 1)
For i = 1 To UBound(rng)
    'search for 3rd letter in cell A1
    If InStr(1, Cells(1, "A") & ",", Mid(rng(i, 1), 3, 1) & ",") Then ' if found
        k = k + 1: res(k, 1) = rng(i, 1) ' store results into array
    End If
Next
If k > 0 Then
    Range("A2:A1000").ClearContents 'delete previous results
    Range("A2").Resize(k, 1).Value = res ' paste results back to sheet
End If
End Sub

Brilliant! works a treat, I would never have come up with that...

Thank you so much for your time

 

[Peter_SSs]

An option without looping through each value ..

Sub Match_Third()
  With Range("A2", Range("A" & Rows.Count).End(xlUp))
    .Value = Evaluate(Replace("if(isnumber(match(""*""&mid(#,3,1)&""*"",A1,0)),#,0)", "#", .Address))
    On Error Resume Next
    .SpecialCells(xlConstants, xlNumbers).Delete Shift:=xlUp
    On Error GoTo 0
  End With
End Sub

 

[Pumper]

An option without looping through each value ..

Sub Match_Third()
  With Range("A2", Range("A" & Rows.Count).End(xlUp))
    .Value = Evaluate(Replace("if(isnumber(match(""*""&mid(#,3,1)&""*"",A1,0)),#,0)", "#", .Address))
    On Error Resume Next
    .SpecialCells(xlConstants, xlNumbers).Delete Shift:=xlUp
    On Error GoTo 0
  End With
End Sub

Hi Peter, sorry for the late reply.

Just tried that and worked perfectly, very nice!

Thank you for taking the time to look at this

 

[Peter_SSs]

You're welcome. Thanks for the follow-up.

 

[Pumper]

I have just noticed that there are the odd few that are actually 5 characters long so the "third character" will not always be correct, is there a way to adjust this code from Peter to do the same but using the second last character as the variable rather than a strict 3rd character?

Sorry to have only noticed this now...

 

[Peter_SSs]

, is there a way to adjust this code from Peter to do the same but using the second last character as the variable rather than a strict 3rd character?

That is not much of a change so try this one

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

 

[Pumper]

That is not much of a change so try this one

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

I would hate to admit how long I tried to solve that

You are a champion Peter! THANK YOU.

 

[Peter_SSs]

I would hate to admit how long I tried to solve that

Stick at trying - it will come with persistence and patience.

Peter! THANK YOU.

Cheers. Glad to help.