VBA: If given characters !, @ and # found in column B then put 1, 2 and 3 in respective cell in Column C

azov5

New Member
Joined
Dec 27, 2018
Messages
40
VBA: If given characters !, @ and # found in column B then put 1, 2 and 3 in respective cell in Column C
VBA: If given characters $, % and & found in column D then put 1, 2 and 3 in respective cell in Column E
Ps. Blank rows present in data
 

Excel Facts

How to total the visible cells?
From the first blank cell below a filtered data set, press Alt+=. Instead of SUM, you will get SUBTOTAL(9,)
Deleted Missing some thing
 
Last edited:
Upvote 0
Hi
I think this what you Want
Correct me if I'm wrong
Code:
Sub Clo_B()
    Application.ScreenUpdating = False
    Dim a As Variant, m, i, lr, t, arr, o1
    o1 = "!@#"
    lr = Cells(Rows.Count, 2).End(xlUp).Row
    ReDim a(1 To lr)
    With CreateObject("VBScript.RegExp")
        .Global = True
        .Pattern = "\!|@|#"
        For t = 1 To lr
            If .test(Cells(t, 2)) Then
                Set m = .Execute(Cells(t, 2))
                Cells(t, 3) = InStr(1, o1, m(0), vbBinaryCompare)
            End If
        Next
    End With
    Application.ScreenUpdating = True
End Sub



Sub Clo_D()
    Application.ScreenUpdating = False
    Dim a As Variant, m, i, lr, t, arr, o1
    o1 = "$%&"
    lr = Cells(Rows.Count, 4).End(xlUp).Row
    ReDim a(1 To lr)
    With CreateObject("VBScript.RegExp")
        .Global = True
        .Pattern = "\$|%|&"
        For t = 1 To lr
            If .test(Cells(t, 4)) Then
                Set m = .Execute(Cells(t, 4))
                Cells(t, 5) = InStr(1, o1, m(0), vbBinaryCompare)
            End If
        Next
    End With
    Application.ScreenUpdating = True
End Sub
 
Last edited:
Upvote 0
Any one of them Peter if found.
Thanks. That then raises another question though.
What would go in column C if 2 or 3 of them are found in column B?

Example, what would go in column C if column B was
abc#23!Q
 
Upvote 0
I actually din't thought about it. Thank you.
Then the output cell will be "1 and 3"
 
Upvote 0
Code:
Sub Clo_B()
    Application.ScreenUpdating = False
    Dim a As Variant, m, i, lr, t, arr, o1, x
    o1 = "!@#"
    lr = Cells(Rows.Count, 2).End(xlUp).Row
    ReDim a(1 To lr)
    With CreateObject("VBScript.RegExp")
        .Global = True
        .Pattern = "\!|@|#"
        For t = 1 To lr
            If .test(Cells(t, 2)) Then
                Set m = .Execute(Cells(t, 2))
                ReDim x(0 To m.Count - 1)
                For i = 0 To m.Count - 1
                x(i) = InStr(1, o1, m(i), vbBinaryCompare)
                Next i
                Cells(t, 3) = Join(x, " Then ")
            End If
        Next
    End With
    Application.ScreenUpdating = True
End Sub
BC
ab@c#23!Q2 Then 3 Then 1
abc#23!Q3 Then 1
abc#23!Q3 Then 1
abc#23!Q3 Then 1
abc#23!Q3 Then 1
abc#23!Q3 Then 1
abc#23!Q3 Then 1
abc#23!Q3 Then 1
ab@c#23!Q2 Then 3 Then 1
abc#23!Q3 Then 1
abc#23!Q3 Then 1
abc#23!Q3 Then 1
n@abc#23!Q2 Then 3 Then 1

<colgroup><col span="2"><col><col></colgroup><tbody>
</tbody>
 
Last edited:
Upvote 0
Code:
Sub Clo_B_nd_D()
    Application.ScreenUpdating = False
    Dim a As Variant, m, i, lr, t, arr, o1, x
    o1 = "!@#"
    o2 = "$%&"
    lr = Cells(Rows.Count, 2).End(xlUp).Row
    ReDim a(1 To lr)
    With CreateObject("VBScript.RegExp")
        .Global = True
        For t = 1 To lr
        .Pattern = "\!|@|#"
            If .test(Cells(t, 2)) Then
                Set m = .Execute(Cells(t, 2))
                ReDim x(0 To m.Count - 1)
                For i = 0 To m.Count - 1
                    x(i) = InStr(1, o1, m(i), vbBinaryCompare)
                Next i
                Cells(t, 3) = Join(x, " Then ")
            End If
            .Pattern = "\$|%|&"
            If .test(Cells(t, 4)) Then
                Set m = .Execute(Cells(t, 4))
                ReDim x(0 To m.Count - 1)
                For i = 0 To m.Count - 1
                    x(i) = InStr(1, o2, m(i), vbBinaryCompare)
                Next i
                Cells(t, 5) = Join(x, " Then ")
            End If
        Next
    End With
    Application.ScreenUpdating = True
End Sub
 
Upvote 0
I actually din't thought about it. Thank you.
Then the output cell will be "1 and 3"
See if this is sufficient

Rich (BB code):
Sub FindCharacters()
  With Range("B2", Range("B" & Rows.Count).End(xlUp))
    .Offset(, 1).Value = Evaluate(Replace("mid(if(isnumber(find(""!"",?)),"" and 1"","""")&if(isnumber(find(""@"",?)),"" and 2"","""")&if(isnumber(find(""#"",?)),"" and 3"",""""),6,99)", "?", .Address))
  End With
  With Range("D2", Range("D" & Rows.Count).End(xlUp))
    .Offset(, 1).Value = Evaluate(Replace("mid(if(isnumber(find(""$"",?)),"" and 1"","""")&if(isnumber(find(""%"",?)),"" and 2"","""")&if(isnumber(find(""&"",?)),"" and 3"",""""),6,99)", "?", .Address))
  End With
End Sub

Some sample data and code results

Excel Workbook
BCDE
1
2abc@ d!f#1 and 2 and 3abc$ gft&gh%1 and 2 and 3
3123@2assa
4
5#dfre3d%2
6ccxc%d2
7$34&fdr1 and 3
Find Characters
 
Last edited:
Upvote 0

Forum statistics

Threads
1,213,536
Messages
6,114,210
Members
448,554
Latest member
Gleisner2

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top