speed up export to text

[Mohan]

Hi
I am exporting the values from Excel to text file (CSV file).
If the total number of rows are few thousands it's OK. But when I have about
50K records, it takes about 45 to 55 minutes. Is there a way to speed up
this export process?

Here is the code I am using (from Erlandsen consulting page) with some
modifications

Public Sub ExportToTextFile(FName As String, _
Sep As String, SelectionOnly As Boolean)

Dim WholeLine As String
Dim FNum As Integer
Dim RowNdx As Long
Dim ColNdx As Integer
Dim StartRow As Long
Dim EndRow As Long
Dim StartCol As Integer
Dim EndCol As Integer
Dim CellValue As String

Application.ScreenUpdating = False
StopMacro = False
On Error GoTo EndMacro:
FNum = FreeFile

If SelectionOnly = True Then
With Selection
StartRow = .Cells(1).Row + 1
StartCol = .Cells(1).Column
EndRow = .Cells(.Cells.Count).Row
EndCol = .Cells(.Cells.Count).Column
End With
Else
With ActiveSheet.UsedRange
StartRow = .Cells(1).Row + 1
StartCol = .Cells(1).Column
EndRow = .Cells(.Cells.Count).Row
EndCol = .Cells(.Cells.Count).Column
End With
End If

Open FName For Output Access Write As #FNum

For RowNdx = StartRow To EndRow
WholeLine = ""
For ColNdx = StartCol To EndCol

' the line below will replace a blank cell with spaces
'If Cells(RowNdx, ColNdx).Value = "" Then
' CellValue = Chr(34) & Chr(34)

'if you like blank fields to be skipped then use this
'if statement replacing the above if statement
If Cells(RowNdx, ColNdx).Value = "" Then
CellValue = ""

Else
CellValue = Cells(RowNdx, ColNdx).Text
End If

If CellValue <> "" Then
WholeLine = WholeLine & CellValue & Sep
End If

Next ColNdx
Application.StatusBar = "Writing row # " & RowNdx & " to file"
WholeLine = Left(WholeLine, Len(WholeLine) - Len(Sep))
Print #FNum, WholeLine
Next RowNdx

Application.ScreenUpdating = True
Close #FNum
Exit Sub

EndMacro:
'On Error GoTo 0
StopMacro = True

If Err.Number = 76 Then
MsgBox "The path specified in the parmsheet does not exist. " & Chr(13) & _
"Please make sure a valid path is specified", vbExclamation
Else
MsgBox "Error encountered " & Err.Number & " - " & Err.Description
End If
Application.ScreenUpdating = True
Close #FNum

End Sub

 

[Mohan]

Also it's killing the CPU - at 100 % (may be that's why it taking so long).
Is there a better way to do this?

Thanks
Mohan

 

[Thomas Ramel]

Grüezi Mohan

Mohan schrieb am 31.05.2006

I am exporting the values from Excel to text file (CSV file).
If the total number of rows are few thousands it's OK. But when I have about
50K records, it takes about 45 to 55 minutes. Is there a way to speed up
this export process?

Maybe you'll be faster if you work with an array and write it to the .CSV
in one step:

Sub SaveCSV_a()
Dim A As Variant
Dim B() As String
Dim D() As String
Dim Z As Long
Dim S As Byte
Dim R As Long
Dim C As Byte

Const Path As String = "C:\Test\"
Const Filename As String = "Test2"
Const Extension As String = ".CSV"
Const Separator As String = ";"
Const Wrapper As String = """"

'Here you can define your own Range, too
A = ActiveSheet.UsedRange

If Not IsEmpty(A) Then
Z = UBound(A, 1)
S = UBound(A, 2)
ReDim B(S - 1)
ReDim D(Z - 1)
For R = 1 To Z
For C = 1 To S
If InStr(1, A(R, C), Separator) > 0 Then
'Rows whith cells including the Separator
'put in Wrapper
B(C - 1) = Wrapper & A(R, C) & Wrapper
Else
B(C - 1) = A(R, C)
End If
Next C
D(R - 1) = Join(B(), Separator)
Next R
Open Path & Filename & Extension For Output As #1
Print #1, "sep=" & Separator & vbCrLf & Join(D(), vbCrLf)
Close #1
End If
End Sub





Regards
Thomas Ramel

 

[dmthornton]

Why not try using excel's built in functionality. Setup a template that
imports the sheet, uses formulas to accomplish the formatting (blank spaces
to "") and then saves the sheet as a csv file.


Example:

Sub ExportXLData()
Dim lngRows As Long

'Copy the data sheet into the template
Workbooks("data.xls").Sheets("Data").Cells.Copy
ThisWorkbook.Sheets("Data").Range("A1")
'Find number of rows
lngRows = ThisWorkbook.Sheets("Data").Range("A65536").End(xlUp).Row - 1

'Template sheet contains formulas to change blank cells to ""
'Example of formula: =IF(Data!A2="","""""",Data!A2)
With ThisWorkbook.Sheets("Template")
'Copy the formulas to all rows
.Range("A2:E2").Copy
.Range("A2", .Range("E2").Offset(lngRows, 0)).PasteSpecial
xlPasteFormulas
'Copy this sheet to a new workbook
.Copy
End With
'Save and close the workbook
With ActiveWorkbook
Application.DisplayAlerts = False
.SaveAs Filename:="C:\export.csv", FileFormat:=xlCSV,
CreateBackup:=False
.Close False
End With
End Sub