Sub Записать_в_текстовые_файлы()
    
    Dim arr(), lr As Long, i As Long, j As Long
    Dim path As String
    
    path = ThisWorkbook.path & "\" & "1-1 4"
    
    For j = 74 To Cells(6, Columns.Count).End(xlToLeft).Column
        lr = Cells(Rows.Count, j).End(xlUp).Row
        If lr > 6 Then
            arr() = Range(Cells(6, j), Cells(lr, j)).Value
            Open path & "\" & arr(1, 1) & ".txt" For Output As #1
            For i = 2 To UBound(arr)
                If arr(i, 1) <> "" Then
                    Print #1, CStr(arr(i, 1))
                End If
            Next i
            Close #1
        End If
    Next j
    
    MsgBox "Готово!", vbInformation
    
End Sub