Excel 2010 - экспорт одного XSLM в несколько файлов CSV

Хорошо, в основном у меня есть файл XSLM, содержащий около 40 тысяч строк. Мне нужно экспортировать эти строки в настраиваемый формат CSV - с разделителями ^ и ~, отмечая границы каждой ячейки. После экспорта они считываются приложением-импортером Joomla и обрабатываются в базе данных. Я нашел хороший макрос-скрипт, который делает именно это, и настроил его, чтобы использовать правильные разделители.

Sub CSVFile()

    Dim SrcRg As Range
    Dim CurrRow As Range
    Dim CurrCell As Range
    Dim CurrTextStr As String
    Dim ListSep As String
    Dim FName As Variant
    FName = Application.GetSaveAsFilename("", "CSV File (*.csv), *.csv")

    'ListSep = Application.International(xlListSeparator)
     ListSep = "^" ' Use ^ as field separator.
    If Selection.Cells.Count > 1 Then
        Set SrcRg = Selection
    Else
        Set SrcRg = ActiveSheet.UsedRange
    End If

    Open FName For Output As #1
    For Each CurrRow In SrcRg.Rows
        CurrTextStr = ìî
        For Each CurrCell In CurrRow.Cells
            CurrTextStr = CurrTextStr & "~" & CurrCell.Value & "~" & ListSep
        Next
        While Right(CurrTextStr, 1) = ListSep
            CurrTextStr = Left(CurrTextStr, Len(CurrTextStr) - 1)
        Wend

        Print #1, CurrTextStr
    Next
    Close #1
End Sub

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

  1. Сохраняет строку заголовка для вставки в каждый файл.
  2. Спрашивает пользователя, сколько строк должно выводиться на файл.
  3. Добавляет -pt # к выбранному имени файла сохранения.
  4. Преобразует файл Excel в необходимое количество файлов CSV.

Например, если мое имя файла было выведено, номер разрыва файла был 5000, а в файле Excel было 14000 строк, я бы получил output-pt1.csv, output-pt2.csv и output-pt3.csv.

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

Очень признателен за любые идеи.


csv excel vba excel-2010
person Clyde    schedule 24.03.2012    source источник
comment
(1) Используйте вариантные массивы вместо циклического перебора диапазонов - гораздо быстрее (2) Объедините длинные строки с комбинированными короткими строками, чтобы избежать двух конкатенаций длинных строк, т.е. CurrTextStr = CurrTextStr & ("~" & CurrCell.Value & "~" & ListSep) (3) Используйте строковую функцию Right$, а не ее более медленный вариант-кузен Right   -  person brettdj    schedule 25.03.2012
comment
См. Создание и запись в файл CSV с помощью Excel VBA для примера, в котором используются эти методы.   -  person brettdj    schedule 25.03.2012

Ответы (2)


arrow_upward
1
arrow_downward

Что-то вроде этого может сработать для вас. Не тестировалось, но компилируется ...

Sub CSVFile()

    Const MAX_ROWS As Long = 5000
    Dim SrcRg As Range
    Dim CurrRow As Range
    Dim CurrCell As Range
    Dim CurrTextStr As String
    Dim ListSep As String
    Dim FName As Variant, newFName As String
    Dim TextHeader As String, lRow As Long, lFile As Long

    FName = Application.GetSaveAsFilename("", "CSV File (*.csv), *.csv")

    'ListSep = Application.International(xlListSeparator)
    ListSep = "^" ' Use ^ as field separator.
    If Selection.Cells.Count > 1 Then
        Set SrcRg = Selection
    Else
        Set SrcRg = ActiveSheet.UsedRange
    End If

    lRow = 0
    lFile = 1

    newFName = Replace(FName, ".csv", "_pt" & lFile & ".csv")
    Open newFName For Output As #1

    For Each CurrRow In SrcRg.Rows
        lRow = lRow + 1
        CurrTextStr = ""
        For Each CurrCell In CurrRow.Cells
            CurrTextStr = CurrTextStr & "~" & CurrCell.Value & "~" & ListSep
        Next
        While Right(CurrTextStr, 1) = ListSep
            CurrTextStr = Left(CurrTextStr, Len(CurrTextStr) - 1)
        Wend

        If lRow = 1 Then TextHeader = CurrTextStr
        Print #1, CurrTextStr

        If lRow > MAX_ROWS Then
            Close #1
            lFile = lFile + 1
            newFName = Replace(FName, ".csv", "_pt" & lFile & ".csv")
            Open newFName For Output As #1
            Print #1, TextHeader
            lRow = 0
        End If

    Next

    Close #1
End Sub
person Tim Williams    schedule 24.03.2012
comment
Отлично, это сработало практически сразу после того, как я получил именно то, что мне нужно. Ниже приведены последние настройки. - person Clyde; 25.03.2012

arrow_upward
0
arrow_downward

Итак, с помощью Тима, вот окончательная версия, которая принимает аргумент о максимальном количестве строк в файле и выводит столько подфайлов, сколько необходимо.

Sub CSVFile()

    Dim MaxRows As Long
    Dim SrcRg As Range
    Dim CurrRow As Range
    Dim CurrCell As Range
    Dim CurrTextStr As String
    Dim ListSep As String
    Dim FName As Variant, newFName As String
    Dim TextHeader As String, lRow As Long, lFile As Long

    FName = Application.GetSaveAsFilename("", "CSV File (*.csv), *.csv")
    MaxRows = Application.InputBox(Prompt:="Enter maximum number of rows per file.", _
        Default:=5000, Type:=1)

    'ListSep = Application.International(xlListSeparator)
    ListSep = "^" ' Use ^ as field separator.
    If Selection.Cells.Count > 1 Then
        Set SrcRg = Selection
    Else
        Set SrcRg = ActiveSheet.UsedRange
    End If

    lRow = 0
    lFile = 1

    newFName = Replace(FName, ".csv", "-pt" & lFile & ".csv")
    Open newFName For Output As #1

    For Each CurrRow In SrcRg.Rows
        lRow = lRow + 1
        CurrTextStr = ""
        For Each CurrCell In CurrRow.Cells
            CurrTextStr = CurrTextStr & "~" & CurrCell.Value & "~" & ListSep
        Next
        While Right(CurrTextStr, 1) = ListSep
            CurrTextStr = Left(CurrTextStr, Len(CurrTextStr) - 1)
        Wend

        If lRow = 1 And lFile = 1 Then TextHeader = CurrTextStr 'Capture the header row

        Print #1, CurrTextStr

        If lRow > MaxRows Then
            Close #1
            lFile = lFile + 1
            newFName = Replace(FName, ".csv", "-pt" & lFile & ".csv")
            Open newFName For Output As #1
            Print #1, TextHeader
            lRow = 0
        End If

    Next

    Close #1
End Sub

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

person Clyde    schedule 30.03.2012