Excel 2010 - Export single XSLM to multiple CSV Files - vba

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:
Stores the header row to be inserted into each file.
Asks the user how many rows should be output per file.
Appends -pt# to the chosen save as file name.
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.