Give this a try

Sub abc()
Dim FoundCell As Range
Dim LastCell As Range
Dim FirstAddr As String
Dim aData, n As Long

    With Range("A:A")
        Set LastCell = .Cells(.Cells.Count)
    End With
    Set FoundCell = Range("A:A").Find(What:=":", After:=LastCell)
    
    If Not FoundCell Is Nothing Then
        FirstAddr = FoundCell.Address
    End If

    ReDim aData(1 To Rows.Count, 1 To 2)
    Do Until FoundCell Is Nothing
        n = n + 1
        aData(n, 1) = Replace(FoundCell.Value, ":", "")
        aData(n, 2) = FoundCell.Offset(4).Value
        Set FoundCell = Range("A:A").FindNext(After:=FoundCell)
        If FoundCell.Address = FirstAddr Then
            Exit Do
        End If
    Loop
    
    Worksheets.Add
    Range("a1").Resize(n, UBound(aData, 2)) = aData
End Sub