systematically selecting text from cells

'=============================================================================
'- USE REGULAR EXPRESSIONS TO FIND SPECIFIED PATTERNS WITHIN STRINGS
'- Brian Baulsom January 2008
'=============================================================================
'- Testing for 1 of 4 possibilities. Most unlikely first.
'- Should only be 1 match from each criterion. Gives message if more.
'- As set checks column A for match.
'- Column B result.
'- Column C for checking code is correct. Not needed when working correctly
'=============================================================================
'- NB. The "is" might be a problem. As set the filter will allow ........
'- "1s","2s" .... "is","xs"
'- Avoiding this may require more expressions to check.
'=============================================================================
'- this could be done with 2 expressions ............
'- ... but I use 4 to make checking templates easier
Const Expression1 As String = "pT[1234ix]s?N[1234ix]s?M[1234ix]s?"
Const Expression2 As String = "T[1234ix]s?N[1234ix]s?M[1234ix]s?"
Const Expression3 As String = "pT[1234ix]s?N[1234ix]s?"
Const Expression4 As String = "T[1234ix]s?N[1234ix]s?"
'-----------------------------------------------------------------------------
Option Base 1
Dim ws As Worksheet
'-
Dim MyRegExp As Object
Dim MyMatches As Variant    ' RegExp results array
Dim ExpArray(4)             ' array to test 4 expressions
Dim Template(4)             'array of templates for checking purposes
Dim MyExpression As String
Dim FoundMatches As Integer ' number of matches. Should only be 1 ?
Dim TestNumber As Integer
'-
Dim FromRow As Long
Dim LastRow As Long
Dim MyString As String
Dim MyResult As String

'=============================================================================
'- MAIN ROUTINE
'=============================================================================
Sub CHECK_DATA()
    '- INITIALISE
    Set ws = ActiveSheet
    Set MyRegExp = CreateObject("VbScript.RegExp")
    LastRow = ws.Range("A65536").End(xlUp).Row
    '-------------------------
    ExpArray(1) = Expression1
    ExpArray(2) = Expression2
    ExpArray(3) = Expression3
    ExpArray(4) = Expression4
    '------------------------
    Template(1) = "pT?N?M?"
    Template(2) = "T?N?M?"
    Template(3) = "pT?N?"
    Template(4) = "T?N?"
    '--------------------------------------------------------------------------
    '- LOOP WORKSHEET CELLS
    For FromRow = 2 To LastRow
        MyString = ws.Cells(FromRow, "A").Value
        '----------------------------------------------------------------------
        '- TEST 4 EXPRESSIONS IN TURN
        For TestNumber = 1 To 4
            '------------------------------------------------------------------
            '- test the expression
            MyExpression = ExpArray(TestNumber)
            With MyRegExp
                .Global = True      ' FINDS ALL MATCHES (NOT JUST FIRST ONE)
                .Pattern = MyExpression
                Set MyMatches = .Execute(MyString) ' always a zero based array
            End With
            '-------------------------------------------------------------------
            '- CHECK FOUND : RESULT TO WORKSHEET
            '- If found - Record result. Exit expression check loop.
            '-------------------------------------------------------------------
            FoundMatches = MyMatches.Count
            If FoundMatches > 0 Then
                MyResult = MyMatches(0)
                ws.Cells(FromRow, "B").Value = MyResult
                '---------------------------------------------------------------
                '- REMOVE THE NEXT LINE IF NOT NEEDED
                ws.Cells(FromRow, "C").Value = Template(TestNumber) ' SHOW TEMPLATE
                '---------------------------------------------------------------
                '- CHECK MORE THAN 1 MATCH
                If FoundMatches > 1 Then
                    rsp = MsgBox("Multiple match in row " & FromRow & ". Continue ?" _
                    & vbCr & "Yes = Continue. No = Go to row." _
                    & "Cancel = Stop", vbYesNoCancel)
                    If rsp = vbYes Then Exit For
                    If rsp = vbCancel Then End
                    If rsp = vbNo Then Application.Goto ws.Range("A" & FromRow): End
                End If
                '---------------------------------------------------------------
                Exit For
            End If
            '-------------------------------------------------------------------
        Next
        '-----------------------------------------------------------------------
        '- NO RESULT
        If TestNumber = 5 And FoundMatches = 0 Then
            ws.Cells(FromRow, "B").Value = "No match"
        End If
    Next
    '---------------------------------------------------------------------------
    '-  finish
    MsgBox ("Done")
End Sub
'=========== end of procedure ==================================================

Application.Calculation = xlCalculationManual