Sub СохранитьЛистВФайл()
      On Error Resume Next
      ' название подпапки, в которую по-умолчанию будет предложено сохранить файл
     Const REPORTS_FOLDER = "HIRZT\"
      ' создаём папку для файла, если её ещё нет
     MkDir ThisWorkbook.Path & "\" & REPORTS_FOLDER
      ' выбираем стартовую папку
     ChDrive Left(ThisWorkbook.Path, 1): ChDir ThisWorkbook.Path & "\" & REPORTS_FOLDER

      ' вывод диалогового окна для запроса имени сохраняемого файла
     Filename = Application.GetSaveAsFilename("latin.pd4", "HIRZT (*.pd4),", , _
                     "Введите имя файла для сохраняемого отчёта", "Сохранить")
      ' если пользователь отказался от выбора имени файла - отменяем сохранение листа в файл
     If VarType(Filename) = vbBoolean Then Exit Sub

      ' копируем активный лист (при этом создаётся новая книга)
     Err.Clear: ActiveSheet.Copy: DoEvents
      If Err Then Exit Sub    ' произошла какая-то ошибка при попытке копирования листа

      ' убеждаемся, что активной книгой является копия листа
     If ActiveWorkbook.Worksheets.Count = 1 And ActiveWorkbook.Path = "" Then
          ' сохраняем файл под заданным именем в формате Excel 2003
         ActiveWorkbook.SaveAs Filename, xlWorkbookNormal
            
          ' закрываем сохранённый файл
         ' (удалите следующую строку, если закрывать созданный файл не требуется)
         ActiveWorkbook.Close False
      End If
End Sub

Sub ExportSheetTXT()

' Параметры для сохраняемого файла
'    cFileName = "" ' имя файла экспорта, по умолчанию - имя активного листа
'    cDelimiter = "," ' разделитель полей
'    cTextQualifier = "" ' квалификатор символьных полей, по умолчанию экв. xlTextQualifierNone для совместимости с SQL
'    cDecimalSeparator = "." ' символ десятичной точки, по умолчанию экв. "dot" для совместимости
'    nStartRow = 1 ' Номер строки на листе - первая строка, с которой выпоняется экспорт (включая заголовок, если есть)
'    nStartCol = 1 ' Номер столбца на листе - первый столбец , с которого выполняется экспорт
'    vCutHeader = True ' Наличие строки заголовка (подписей столбцов) и его удаление:
'       =True=-1 - заголовок считается равным 1 строке, при этом из результирующего файла заголовок исключается
'       <0 - размер заголовка в строках, исключается из результата
'       >0 - размер заголовка в строках, не исключается из результата (но записывается "как есть", без преобразований)
'       =False=0 - заголовок отсутствует
'    cFormatdateTime = "YYYY-MM-DD hh:mm:ss" ' формат даты/времени, по умолчанию выставлен в ISO8601 для совместимости
'    cTypeQualifier = "#" ' квалификатор логических значений и даты, по умолчанию - пустаое значение

     Dim wb As Workbook, newwb As Workbook, sh As Worksheet, newsh As Worksheet
     Dim nLastRow As Long, nLastCol As Long, i As Long, j As Long
     Dim cOut As String, cValue

     Application.ScreenUpdating = False

     Set wb = ActiveWorkbook
     Set sh = ActiveSheet
     Set newwb = Workbooks.Add
     Set newsh = newwb.Sheets(1)

     ' Установки границ экспортируемой таблицы
     ' Правая-нижняя граница выставляется по используемой области листа
     nLastRow = sh.UsedRange.Row + sh.UsedRange.Rows.Count - 1
     nLastCol = sh.UsedRange.Column + sh.UsedRange.Columns.Count - 1
     ' Левая-верхняя граница подтягивается к началу заполнения на листе
     nStartRow = Application.WorksheetFunction.Max(nStartRow, sh.UsedRange.Row)
     nStartCol = Application.WorksheetFunction.Max(nStartCol, sh.UsedRange.Column)
     ' ВНИМАНИЕ - заголовок будет отсчитан от нового левого-верхнего положения
     ' Анализ заголовка
     vCutHeader = vCutHeader + 0
     If vCutHeader < 0 Then nStartRow = nStartRow - vCutHeader
     ' Сборка данных
     For i = nStartRow To nLastRow
         vCutHeader = vCutHeader - 1
         cOut = ""
         For j = nStartCol To nLastCol
             cValue = sh.Cells(i, j)
             If vCutHeader < 0 Then    ' не строка заголовка
                 Select Case VarType(cValue)
                 Case vbString
                     cValue = cTextQualifier & cValue & cTextQualifier
                 Case vbInteger, vbLong, vbByte
                     cValue = CStr(cValue)
                 Case vbSingle, vbDouble, vbCurrency, vbDecimal
                     cValue = Replace(CStr(cValue), Application.International(xlDecimalSeparator), cDecimalSeparator)
                 Case vbBoolean
                     cValue = cTypeQualifier & CStr(cValue) & cTypeQualifier
                 Case vbDate
                     cValue = cTypeQualifier & Format(cValue, cFormatDateTime) & cTypeQualifier
                 Case Else
                     ' Все значения ошибок
                     cValue = ""
                 End Select
             End If
             cOut = cOut & cDelimiter & CStr(cValue)
         Next
         newsh.Cells(i - nStartRow + 1, 1) = Mid(cOut, 1)
     Next

     Set newsh = Nothing

     ' Сохранение файла
     Dim vFilename
     If Len(cFileName) = 0 Then cFileName = sh.Name & ".txt"
     vFilename = Application.GetSaveAsFilename("пример.txt", "ФОРМАТ ПРОБЫ (*.txt),", , _
                    "Введите имя файла для сохраняемого отчёта", "Сохранить")
     ' если пользователь отказался от выбора имени файла - отменяем сохранение листа в файл
     If VarType(vFilename) = vbBoolean Then
         If InStr(1, cFileName, "\") = 0 Then cFileName = wb.Path & "\" & cFileName
     Else
         vFilename = Replace(vFilename, Dir(vFilename, 16), "")
         cFileName = vFilename & cFileName
     End If

     Application.DisplayAlerts = False
     newwb.SaveAs Filename:=(cFileName), FileFormat:=xlTextPrinter, CreateBackup:=False, local:=True
     Application.DisplayAlerts = True
     newwb.Close savechanges:=False
     ' *
     Set newwb = Nothing
     wb.Activate

     Application.ScreenUpdating = True

     Set sh = Nothing
     Set wb = Nothing

End Sub

        vFilename = Replace(vFilename, Dir(vFilename, 16), "")
          vFilename = Replace(vFilename, "пример.txt", "")
          cFileName = vFilename & cFileName

vFilename = Application.GetSaveAsFilename("пример.txt", "ФОРМАТ ПРОБЫ (*.txt),", , _
                     "Введите имя файла для сохраняемого отчёта", "Сохранить")
     ' если пользователь отказался от выбора имени файла - отменяем сохранение листа в файл
     If VarType(vFilename) = vbBoolean Then Exit Sub
     cFileName = vFilename

newwb.SaveAs Filename:=(cFileName), FileFormat:=xlTextPrinter, CreateBackup:=False, local:=True

If VarType(vFilename) = vbBoolean Then
         If InStr(1, cFileName, "\") = 0 Then cFileName = wb.Path & "\" & cFileName
     Else
         vFilename = Replace(vFilename, Dir(vFilename, 16), "")
         cFileName = vFilename & cFileName
     End If

ExportSheet2CSV

Sub ExportData()

vFilename = Application.GetSaveAsFilename("пример.txt", "ФОРМАТ ПРОБЫ (*.txt),", , _
                      "Введите имя файла для сохраняемого отчёта", "Сохранить")
      ' если пользователь отказался от выбора имени файла - отменяем сохранение листа в файл
      If VarType(vFilename) = vbBoolean Then Exit Sub
      cFileName = vFilename