Untitled

Sub ExtractPattern()
    Dim ws As Worksheet
    Dim lastRow As Long
    Dim i As Long
    Dim regex As Object
    Dim match As Object
    
    Set ws = ThisWorkbook.ActiveSheet
    lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
    
    Set regex = CreateObject("VBScript.RegExp")
    regex.Pattern = "\*-\*-"
    regex.Global = True
    
    For i = 1 To lastRow
        Set match = regex.Execute(ws.Cells(i, "A").Value)
        If match.Count > 0 Then
            ws.Cells(i, "B").Value = match(0).Value
        End If
    Next i
End Sub