extract partial string from Cell

Sub ParseNum()
Dim Rng As Variant
Dim LastRow As Long
Dim A As Variant
Dim B as Long

    With ActiveSheet
        LastRow = .Cells(.Rows.Count, "H").End(xlUp).Row
    
        Rng = .Range("H2:H" & LastRow).Value
        
        For B = 1 To UBound(Rng)
            A = Split(Rng(B, 1), " ")
            .Range("J" & B + 1) = Trim(A(1))
        Next
    End With
End Sub

Hello sydcoco,

Welcome to the Forum!

This macro will search the text of each cell in column "E" starting in row 1 for the words "Joblist" followed by at least one space, 4 digits with or without a alpha character, and the word "provided". Case is ignored in the search and the cell text can be any length.

Any matches will have the number copied to the adjacent cell in column "G". You can change the starting cell in column "E" to where you want to start and the result column from "G" to the column you choose.

Sub ExtractString()

    Dim c As Long
    Dim Cell As Range
    Dim FirstCell As Range
    Dim LastCell As Range
    Dim RegExp As Object
    Dim ResultColumn As String
    Dim SearchRng As Range
    Dim Text As String
    
        ResultColumn = "G"
        
        Set FirstCell = Range("E1")
        
            Set LastCell = Cells(Rows.Count, "E").End(xlUp)
            If LastCell.Row < FirstCell.Row Then MgBox "There is no data to search.": Exit Sub

            Set SearchRng = Range(FirstCell, LastCell)
            
            c = Cells(1, ResultColumn).Column -  SearchRng.Column
            
            Set RegExp = CreateObject("VBScript.RegExp")
            RegExp.IgnoreCase = True
            RegExp.Pattern = ".*Joblist\s+(\d{4}[a-z]?)\s.+(?=provided).*"
        
            For Each Cell In SearchRng
                Text = Cell.Value
                If RegExp.Test(Text) = True Then
                    Cell.Offset(0, c) = RegExp.Replace(Text, "$1")
                End If
            Next Cell
                
End Sub

Hi Syd,

Something like this:

Sub Syd(): Dim E As Range, i As Integer, j As Integer
For Each E In Range("E1:E" & Range("E" & Rows.Count).End(xlUp))
If InStr(1, E, "Joblist") Then
i = InStr(1, E, " "): j = InStr(i, E, " ")
E.Offset(0, 3) = Mid(E, i + 1, j - i - 1)
End If: Next: End Sub

Change the red number to however far you want the offset to be.

Directions for running the routine(s) just supplied

Copy the code to the clipboard

Press ALT + F11 to open the Visual Basic Editor.

Open a macro-enabled Workbook or save your Workbook As Macro-Enabled

Select “Module” from the Insert menu

Type "Option Explicit" then paste the code under it

With the cursor between Sub and End Sub press F5 (F8 to Single Step)

OR

Press ALT + Q to close the code window.

Press ALT + F8 then double click on the macro name

Hello sydcoco,

Sorry about the typos. Glad you were able to fix them and get it working. I will change the code I posted to reflect what you did. Thanks.

Hello sydcoco,

The message box will only display if the LastCell row in column "E" is less than the FirstCell row. In this macro the starting cell (FirstCell) is "E1". The lastCell row will never be less than 1.