Экспорт таблицы (диапазона ячеек) в CSV

Sub ЭкспортПрайсЛистаВФорматеCSV()
    On Error Resume Next
    Dim sh As Worksheet: Set sh = ActiveSheet    ' обрабатывается активный лист

    ' диапазон ячеек с A5 до последней заполненной ячейки в столбце A
    ' расширенный по горизонтали на 10 столбцов (выгружаются столбцы с A по J)
    Dim ra As Range: Set ra = sh.Range(sh.[A5], sh.Range("A" & sh.Rows.Count).End(xlUp)).Resize(, 10)
 
    ' формируем текстовую строку, содержащую текст диапазона в формате CSV
    CSVtext$ = Range2CSV(ra, ";")    ' можно указать другой разделитель столбцов

    ' создаём в папке с файлом XLS подпапку для CSV-прайсов (если такой папки ещё нет)
    CSVfolder$ = ThisWorkbook.Path & "\CSV prices\": MkDir CSVfolder$
 
    ' формируем имя создаваемого файла CSV (c указанием текущей даты)
    CSVfilename$ = Format(Now, "YYYY MM DD  HH-NN-SS") & ".csv"
 
    ' сохраняем текстовую CSV-строку CSVtext$ в файл с именем CSVfilename$
    SaveTXTfile CSVfolder$ & CSVfilename$, CSVtext$
End Sub

Function Range2CSV(ByRef ra As Range, Optional ByVal ColumnsSeparator$ = ";", _
                   Optional ByVal RowsSeparator$ = vbNewLine) As String
    If ra.Cells.Count = 1 Then Range2CSV = ra.Value & RowsSeparator$: Exit Function
    If ra.Areas.Count > 1 Then
        Dim ar As Range
        For Each ar In ra.Areas
            Range2CSV = Range2CSV & Range2CSV(ar, ColumnsSeparator$, RowsSeparator$)
        Next ar
        Exit Function
    End If
    arr = ra.Value
    buffer$ = ""    ' иначе конкатенация длинных текстовых строк притормаживает макрос
    For i = LBound(arr, 1) To UBound(arr, 1)
        txt = "": For j = LBound(arr, 2) To UBound(arr, 2): txt = txt & ColumnsSeparator$ & arr(i, j): Next j
        Range2CSV = Range2CSV & Mid(txt, Len(ColumnsSeparator$) + 1) & RowsSeparator$
        ' для многократного увеличения производительности при больших диапазонах данных
        If Len(Range2CSV) > 50000 Then buffer$ = buffer$ & Range2CSV  : Range2CSV = ""
    Next i
    Range2CSV = buffer$ & Range2CSV
End Function

Function Range2CSV(ByRef ra As Range, Optional ByVal ColumnsSeparator$ = ";", _
                   Optional ByVal RowsSeparator$ = vbNewLine) As String
    If ra.Cells.Count = 1 Then Range2CSV = ra.Value & RowsSeparator$: Exit Function
    If ra.Areas.Count > 1 Then
        Dim ar As Range
        For Each ar In ra.Areas
            Range2CSV = Range2CSV & Range2CSV(ar, ColumnsSeparator$, RowsSeparator$)
        Next ar
        Exit Function
    End If
    arr = ra.Value
 
    ' иначе конкатенация длинных текстовых строк притормаживает макрос
    chr34$ = Chr(34): buffer$ = "": buffer2$ = "": Const BufferLen& = 15000
    For i = LBound(arr, 1) To UBound(arr, 1)
        txt = "": For j = LBound(arr, 2) To UBound(arr, 2)
            txt = txt & ColumnsSeparator$ & chr34$ & Replace(arr(i, j), chr34$, "'") & chr34$
        Next j
 
        buffer$ = buffer$ & Mid(txt, Len(ColumnsSeparator$) + 1) & RowsSeparator$
 
        ' для многократного увеличения производительности при больших диапазонах данных
        If Len(buffer$) > BufferLen& Then
            buffer2$ = buffer2$ & buffer$: buffer$ = ""
            If Len(buffer2$) > BufferLen& * 40 Then _
               Range2CSV = Range2CSV & buffer2$: buffer2$ = "" ': DoEvents
        End If
 
    Next i
    Range2CSV = Range2CSV & buffer2$ & buffer$
End Function

Function SaveTXTfile(ByVal filename As String, ByVal txt As String) As Boolean
    On Error Resume Next: Err.Clear
    Set fso = CreateObject("scripting.filesystemobject")
    Set ts = fso.CreateTextFile(filename, True)
    ts.Write txt: ts.Close
    SaveTXTfile = Err = 0
    Set ts = Nothing: Set fso = Nothing
End Function