Excel 2010 - Export single XSLM to multiple CSV Files

Question

Alright, so, basically I have an XSLM file containing about ~40k rows. I need to export these rows to a customized CSV format - ^ delimited and ~ marking the boundaries of each cell. Once they've been exported, they are read in by a Joomla importer app and processed into the database. I found a good macro script which does just that and tweaked it to use the correct delimiters.

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

However, what've I've found is that the generated CSVs are simply too big to be handled with the available script execution time. I can split the files manually to about 5000 rows apiece and it does well enough. What I'd like to do is adjust the above script as follows:

1. Stores the header row to be inserted into each file.
2. Asks the user how many rows should be output per file.
3. Appends -pt# to the chosen save as file name.
4. Processes out the Excel file into as many 'chunk' csv files as required.

For example, if my file name was output, the file break number was 5000, and the excel file had 14000 rows, I'd end up with output-pt1.csv, output-pt2.csv, and output-pt3.csv.

If it were just me doing it, I'd just keep breaking the files manually, but when all is said and done I need to hand these files off to the client commissioning the project, so the easier the better.

Much appreciated for any ideas.

Answer 1

Something like this might work for you. Untested, but compiles...

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

Answer 2

So, with Tim's help, here's the final version that accepts an argument on the max number of rows per file, and outputs to as many sub files as needed.

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

I just added a request for user input to get the max rows, and also tweaked it so it didn't update the header row with each new file. Thanks again for the help.