Sub importTxt()
    Dim A(), Sh As Worksheet
    Set Sh = ActiveSheet
    Filename = Get_FileName
    Set objFSO = CreateObject("Scripting.FileSystemObject")
    Set objTextFile = objFSO.OpenTextFile(Filename, 1)
    Set RegExp = CreateObject("VBScript.RegExp")
    RegExp.Pattern = "(\d{7,})\D+([0-9\.]+)\D+(\d+)"
    LastRow = Sh.Cells(Sh.Rows.Count, 1).End(xlUp).Row
    If Sh.Cells(1, 1) <> "" Then LastRow = LastRow + 1
    Do Until objTextFile.AtEndOfStream    'пока не кончился файл
        s = objTextFile.ReadLine    'читаем построчно
        Set oMatches = RegExp.Execute(s)
        If oMatches.Count > 0 Then
            ReDim A(1 To 1, 1 To 3)
            A(1, 1) = oMatches(0).subMatches(0)
            A(1, 2) = Val(oMatches(0).subMatches(1))
            A(1, 3) = oMatches(0).subMatches(2)
            Sh.Cells(LastRow, 1).Resize(1, 3) = A
            LastRow = LastRow + 1
        End If
    Loop
    objTextFile.Close
    Set objTextFile = Nothing
    Set RegExp = Nothing
    Set objFSO = Nothing

End Sub
Function Get_FileName(Optional ByVal Title As String = "Выберите файл для обработки", _
                      Optional ByVal FilterDescription As String = "Файлы TXT", _
                      Optional ByVal FilterExtention As String = "*.txt") As String
    On Error Resume Next
    With Application.FileDialog(msoFileDialogOpen)    '
        .ButtonName = "Выбрать": .Title = Title: .InitialFileName = InitialPath
        .Filters.Clear: .Filters.Add FilterDescription, FilterExtention
        If .Show <> -1 Then Exit Function
        Get_FileName = .SelectedItems(1)
    End With
End Function