Option Base 1

Sub ColumnToTable()
Dim arr()
Dim tblArr()
Dim I&, N&, J&, K&
Dim iPatt$, iFrmt$
On Error Resume Next
With Worksheets("Лист1")
  arr = .Range("A1:A" & .Cells(.Rows.Count, "A").End(xlUp).Row).Value
  ReDim tblArr(1 To UBound(arr, 1), 1 To 7)
  For I = LBound(arr, 1) To UBound(arr, 1)
    If arr(I, 1) Like "ID:*" Then
      N = N + 1: K = 0
      For J = I - 1 To I + 4
        K = K + 1
        Select Case K
          Case 1, 6, 7
            tblArr(N, K) = Format(RegExpExtract(Replace(arr(J, 1), " ", ""), "\d+"), "#,##0")
          Case 2
            tblArr(N, K) = arr(J, 1)
          Case 3
            tblArr(N, K) = CDbl(RegExpExtract(Replace(arr(J, 1), " ", ""), "([1-9]\d|[1-9])\d+([.,]\d+)?"))
          Case 4
            tblArr(N, K) = RegExpExtract(Replace(arr(J, 1), " ", ""), "\d+")
            K = K + 1
            tblArr(N, K) = RegExpExtract(Replace(arr(J, 1), " ", ""), "\d+", 2)
        End Select
      Next
    End If
  Next
  .Range("C13").Resize(N, 7) = tblArr
End With
End Sub

Public Function RegExpExtract(Text As String, Pattern As String, Optional Item As Integer = 1) As String
    On Error GoTo ErrHandl
    Set regex = CreateObject("VBScript.RegExp")
    regex.Pattern = Pattern
    regex.Global = True
    If regex.Test(Text) Then
        Set matches = regex.Execute(Text)
        RegExpExtract = matches.Item(Item - 1)
        Exit Function
    End If
ErrHandl:
    RegExpExtract = CVErr(xlErrValue)
End Function