Find, delete in cell

Option Explicit

'required reference to MS VBScript Regular Expression 5.5
Sub RemoveMatches()
Dim wsh As Worksheet, oRegEx As VBScript_RegExp_55.RegExp 
Dim i As Integer, sTmp As String, sPattern As String

On Error GoTo Err_RemoveMatches

Set wsh = ThisWorkbook.Worksheets(1)

sPattern = "\W*([a-zA-Z]{1,} [0-9]{5})"
i = 1
Do While wsh.Range("A" & i) <> ""
    sTmp = wsh.Range("A" & i)
    Set oRegEx = New VBScript_RegExp_55.RegExp
    With oRegEx
        .Pattern = sPattern
        .Global = False
        .IgnoreCase = True
        .MultiLine = False
        'find "Word 12345" and replace with empty string
        sTmp = .Replace(sTmp, "")
    End With
    'insert new value
    wsh.Range("A" & i) = sTmp
    Set oRegEx = Nothing
    i = i + 1
Loop

Exit_RemoveMatches:
    On Error Resume Next
    Set wsh = Nothing
    Set oRegEx = Nothing
    Exit Sub

Err_RemoveMatches:
    MsgBox Err.Description, vbExclamation, Err.Number
    Resume Exit_RemoveMatches

End Sub