Excel VBA从单元格中提取文本

Question

I have tried looking through Stack Overflow for previous suggestions but haven't found any that have worked.

Here is my situation: I am trying to look at a simple Excel sheet which shows someone's name, position, and then their "Role" which is a custom field I am creating. Right now, I am looking to just do "Engineers" but will also expand to things like "Admin Assistant" and "Manager". (The real spreadsheet is about 8100 lines long).

Here is an example of some test data:

All I need is to scan through the "Title" column, see if it matches a String (in this case, my test string is engineer), and then to copy the String and the remaining I or II or III or in some cases, IV after it.

I have heard about using a regular expression and have used them in SQL before, but am struggling coming up with what I need. Here is my current code where I tried using the MID function:

Sub GetRole()
' Custom function written to take role out of official title

strRole = "Engineer" ' String to check for
Dim lrow As Integer ' Number of Rows
Dim Role As String ' Role to write into adjacent cell

lrow = Cells(Rows.Count, "B").End(xlUp).Row

For i = lrow To 2 Step -1
    If InStr(1, Cells(i, 2), "Engineer") > 0 Then
        Role = Mid(Cells(i,3)), 1, 5)
    Cells.(i, 3).Value = Role
    End If
Next i

End Sub

But that didn't quite work. Any help or advice would be greatly appreciated. I am willing to provide any extra information necessary.

Answer 1

You can solve this using Regular Expressions. First you need to enable the reference which you do so by going to Tools > References... and enable Microsoft VBScript Regular Expressions 5.5

Then use the following code to generate your answers

Sub GetRole()
    ' Custom function written to take role out of official title

    ' Uncomment the below if using Early Binding i.e. you enable the reference
    ' Dim ReGex As New RegExp
    ' Comment below line if decide to use Late Binding (i.e. you enable the reference)
    Dim ReGex As Object
    Dim i As Long, lrow As Long ' Number of Rows

    ' Comment the below line if decide to use Late Binding (i.e. you enable the reference)
    Set ReGex = CreateObject("VBScript.RegExp")

    With ReGex
        .Global = True
        .IgnoreCase = True
        .Pattern = "(Engineer\sI*\b)"
    End With

    With ActiveSheet
        lrow = .Cells(.Rows.Count, "B").End(xlUp).Row
        For i = lrow To 2 Step -1
            If ReGex.test(.Cells(i, 2).Value2) Then .Cells(i, 3).Value2 = Trim(ReGex.Execute(Cells(i, 2).Value2)(0))
        Next i
    End With
End Sub

Generates output:

Answer 2

I think Excel formula will be easier to extend compared to debugging VBA and Regex:

=IF(ISNUMBER(  FIND("Engineer III", E4)), "Engineer III",
 IF(ISNUMBER(  FIND("Engineer II" , E4)), "Engineer II", 
 IF(ISNUMBER(SEARCH("Engineer *I" , E4)), "Engineer I", "")))