Option Explicit

Public fso As Object

Sub Main()
    Set fso = CreateObject("Scripting.FileSystemObject")
    Dim arr As Variant
    arr = GetArr(ActiveSheet)
    If Not IsEmpty(arr) Then
        PrintArr arr
    End If
End Sub

Sub PrintArr(arr As Variant)
    Dim y As Long
    Dim u As Long
    Dim i As Long
    Dim x As Integer
    Dim txt As String
    For y = 2 To UBound(arr, 1)
        u = y
        Do
           If u = UBound(arr, 1) Then Exit Do
           If arr(u + 1, 1) <> arr(u, 1) Then Exit Do
           u = u + 1
        Loop
        txt = arr(y, 1) & vbTab & arr(y, 2) & vbCrLf
        For i = y To u
            For x = 3 To UBound(arr, 2)
                txt = txt & arr(i, x) & vbTab
            Next
            txt = txt & vbCrLf
        Next
        WriteTxtFile txt
        y = u
    Next
End Sub

Sub WriteTxtFile(txt As String)
    Static i As Long
    i = i + 1
    Dim sFile As String
    sFile = ThisWorkbook.Path & "\" & Right("00000" & i, 6) & ".txt"
    On Error Resume Next
    Kill sFile
    On Error GoTo 0
    With fso.CreateTextFile(sFile)
        .Write txt
        .Close
    End With
End Sub

Function GetArr(sh As Worksheet) As Variant
    With sh
        GetArr = .Range(.Cells(1, 1), .Cells(.Rows.Count, 1).End(xlUp).Cells(1, 8))
    End With
End Function