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

Часто при формировании прайс-листов требуется выгрузить большой объём данных в текстовый файл в формате CSV (разделитель - точка с запятой, или запятая)
И далеко не всегда может помочь сохранение файла в этом формате, поскольку в выгрузку попадают лишние данные (заголовки таблиц, лишние строки и столбцы, и т.д.)

В данном случае поможет экспорт заданного диапазона ячеек в файл CSV, что проще всего сделать макросом с использованием функции Range2CSV:

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

Вот код самой функции Range2CSV:

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

Для работы макроса понадобится ещё и функция сохранения текстового файла SaveTXTfile.
Найти её можно здесь: http://excelvba.ru/code/txt

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

Комментарии

Настройки просмотра комментариев

Выберите нужный метод показа комментариев и нажмите "Сохранить установки".

Если нужно чтобы выводились данные до первой пустой ячейки первого столбца.:
После строки
If Len(Range2CSV) > 50000 Then buffer$ = buffer$ & Range2CSV: Range2CSV = ""
Добавляем строку:
If arr(i + 1, 1) = "" Then i = 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

на

txt = "": For j = LBound(arr, 2) To UBound(arr, 2)
  if  j = 2 or j = 5 then ' 2 и 5 столбцы выгружаем в денежном формате
            txt = txt & ColumnsSeparator$ & format(arr(i, j), "0.00")
  else ' а остальные - в текстовом
            txt = txt & ColumnsSeparator$ & chr34$ & Replace(arr(i, j), chr34$, "'") & chr34$
  end if            
Next j

Доброго времени суток!

А как сделать,чтоб значения в ячейках выгружались в числовом или денежно формате с двумя знаками после запятой?
Вот например есть 4499795,40 выгружается 4499795,4 или 900 000,00 выгружается 900000

Здравствуйте, Виталий
Возможно, кодировка нужна другая.
Перекодировать CSV файл (например, в UTF-8) можно этой функцией:
http://ExcelVBA.ru/code/encode

Всё хорошо. Только при импорте файла csv в престашоп возникает ошибка . С чем может быть связана?

спасибо! теперь запускается.

подскажите, почему таблица остается таблицей, а не переходит в вид столбца в выгружаемом файле?
при этом, если в строке
CSVtext$ = Range2CSV(ra, ";")
поменять точку с запятой на запятую, то таблица становится столбцом, но запятые в цифрах при этом путаются с запятыми-разделителями. если же поставить точку, то она будет путаться с точками в дате.

не понимаю, как работает эта последняя функция, поэтому не знаю, как это победить

В статье дана ссылка на функцию SaveTXTfile
Надо было код этой функции тоже вставить в ваш файл - и всё сразу заработает.

на SaveTXTfile пишет Sub or Function not defined

Ну так сделайте цикл, в котором будут просматриваться все строки таблицы.

Пример кода написать не могу, не видя ваш файл.
Если сами не справитесь - можете заказать разработку такого макроса (оформите заказ, прикрепив вашу таблицу, и разъяснив, что и куда должно выгружаться)

Подскажите, пожалуйста, как сделать, чтоб выгружать не сплошной диапазон, а только строки, у которых (например) в 11 колонке написано имя формируемого файла?
В идеале будет генерироваться несколько файлов, имена файлов которых прописаны в 11 колонке. В диапазоне возможно наличие строк, у которых значение равно цифре 0

Спасибо, за оперативный ответ.
В новом файле все заработало. Буду искать где были конфликты.
Отдельное спасибо за полезный ресурс.

Не должна эта строка выдавать ошибку, если только мой макрос не конфликтует с существующими в том же файле вашими макросами.

Попробуйте код на новом файле (в котором нет других макросов), и заново скопируйте необходимые макросы с моего сайта.
Если в новом файле проблема исчезнет - ищите проблему несовместимости в своих макросах.

В строке
txt = "": For j = LBound(arr, 2) To UBound(arr, 2): txt = txt & ColumnsSeparator$ & arr(i, j): Next j
Выделяет (txt =) с коментарием: Expected function or variable

Спасибо за оперативный ответ, попробуем

Ну почему же "код должен быть чисто своим"?
Я вот и чужой код часто использую - просто не удивляюсь, если он работает не совсем так, как хочелось бы, а дорабатываю его под свои нужды.

Я использовал функцию только для выгрузки диапазонов, заведомо не содержащих символа разделителя в обрабатываемых ячейках.
Если такие символы присутствуют - надо знать, как их экранировать.

Тут есть много вариантов:

  • предварительно заменить разделитель в ячейке на какой-то другой символ
  • заменить разделитель на другой символ только в выгрузке CSV (в ячейке оставить как было)
  • экранировать сам символ разделителя (например, текст 123;456 заменить на 123";"456 или на 123/;456)
  • экранировать всю ячейку в выгрузке (например, текст 123;456 заменить на "123;456")
  • и т.д. и т.п. (при нескольких разделителях в ячейке появляются ещё варианты)

Предусматривать все эти варианты в макросе не очень хочется - объём кода заметно увеличится, а желающих внести какие-то дополнительные "навороты" только прибавится.

В вашем случае всё решалось заменой одной строки кода:

txt = "": For j = LBound(arr, 2) To UBound(arr, 2): txt = txt & ColumnsSeparator$ & arr(i, j): Next j

Надо вместо arr(i, j) подставить некую функцию, которая произведёт изменения текста в элементе массива при наличии в нём символов разделителей.

Добры вечар!

к сожалению не совсем корректно работает Function Range2CSV - если внутри ячейки содержится разделитель (у меня это была сложная гиперссылка) -исходнй ЦээСВэ искажается - при копипасте исохранить в формате csv -всё прекрасно

ну даже не знаю говорить ли спасибо? :) полдня промудохался
СПАСИБО - будет Муку наука - код должен быть чисто своим

Отправить комментарий

Содержание этого поля является приватным и не предназначено к показу.
CAPTCHA
Подтвердите, пожалуйста, что вы - человек:
 __  __  _____                 __   __        
\ \/ / | ___| _ __ _ __ \ \ / / __ _
\ / | |_ | '__| | '_ \ \ V / / _` |
/ \ | _| | | | | | | | | | (_| |
/_/\_\ |_| |_| |_| |_| |_| \__, |
|___/
Введите код, изображенный в стиле ASCII-арт.

Не получается применить макрос? Не удаётся изменить код под свои нужды?

Оформите заказ у нас на сайте, не забыв прикрепить примеры файлов, и описать, что и как должно работать.