Save text to file in Excel VBA

Blog‎ > ‎IT‎ > ‎

posted Dec 29, 2013, 3:00 AM by Jake Vosloo [ updated Dec 29, 2013, 3:05 AM ]

This VBA script will save the text from one column (O) into a file for which the name is taken from column (K).

Surprisingly this method, which opens and closes a file for each row of the sheet is much faster than the method I describe here, which tells Excel to save sheets to file as csv. I presume the overhead is due to Excel having to serialise the sheets to CSV format.

Public Sub ExportPastelCSV()
On Error GoTo HandleErr

Dim ThisRow As Range
Dim OutputPath As String
Dim OutputFile As String
Dim OutputRow As String

Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
Application.CalculateFullRebuild

'Make a folder with the name of the worksheet
OutputPath = Left(ThisWorkbook.Name, InStr(ThisWorkbook.Name, ".") - 1) 'Simple but bad way to remove the extension.
OutputPath = ThisWorkbook.path & Application.PathSeparator & OutputPath
If Dir(OutputPath, vbDirectory) = "" Then
    MkDir OutputPath
Else
    If Dir(OutputPath & "\*.*") <> "" Then
        Kill OutputPath & "\*.*"
    End If
End If

Dim TheSheet As Worksheet
Set TheSheet = ThisWorkbook.ActiveSheet
Dim TheRange As Range
Set TheRange = ThisWorkbook.ActiveSheet.UsedRange

If TheRange.Rows.Count > 1 Then
   Set TheRange = TheRange.Resize(TheRange.Rows.Count - 1, TheRange.Columns.Count).Offset(1, 0)

    For Each ThisRow In TheRange.Rows
    OutputFile = ThisRow.Cells(1, 11).Value
        If OutputFile <> "" Then
            OutputRow = ThisRow.Cells(1, 15).Value
            OutputFile = OutputPath & Application.PathSeparator & OutputFile & ".csv"
            Open OutputFile For Append Lock Write As #1
            Write #1, OutputRow
            Close #1
        End If
    Next ThisRow
End If

MsgBox "Successfully exported the Pastel CSV files in a folder with the same name as this worksheet:" & vbCrLf & OutputPath & vbCrLf

Finally:
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Application.EnableEvents = True
Exit Sub

HandleErr:
MsgBox "Couldn't save all sheets to CSV." & vbCrLf & _
        "Source: " & Err.Source & " " & vbCrLf & _
        "Number: " & Err.Number & " " & vbCrLf & _
        "Description: " & Err.Description & " " & vbCrLf

GoTo Finally
End Sub

Comments