extract partial string from Cell

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