Excel visual basic (vba) macro to save a (selection) of a table to an utf-8 csv file

Excel vba macro to save a (selection) of a table to an utf-8 csv file

Public Sub ExportToCsv()

     Dim FName As String

     Dim Sep As String

     Dim Enclose As String

     Dim wsSheet As Worksheet

     Dim nFileNum As Integer

     Dim csvPath As String

     'Sep = InputBox("Enter a single delimiter character (e.g., comma or semi-colon)", "Export To Text File")

     Sep = ";"

     Enclose = """"

     'csvPath = InputBox("Enter the full path to export CSV files to: ")

     'csvPath = GetFolderName("Choose the folder to export CSV files to:")

     'If csvPath = "" Then

     '    MsgBox ("You didn't choose an export directory. Nothing will be exported.")

     '    Exit Sub

     'End If

     'For Each wsSheet In Worksheets

          'wsSheet.Activate

          Set wsSheet = ActiveSheet

          FName = ActiveWorkbook.Path & "\" & wsSheet.Name & ".csv"

          ExportToUTF8CsvFile FName, Sep, Enclose, True

     'Next wsSheet

End Sub

Public Sub ExportToUTF8CsvFile(FName As String, Sep As String, Enclose As String, SelectionOnly As Boolean)

    Dim WholeLine As String

    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

    Dim fso, file, test

    Application.ScreenUpdating = False

    On Error GoTo EndMacro:

    If SelectionOnly = True Then

        With Selection

            StartRow = .Cells(1).Row

            StartCol = .Cells(1).Column

            EndRow = .Cells(.Cells.Count).Row

            EndCol = .Cells(.Cells.Count).Column

            If (StartRow – EndRow) = 0 And (StartCol – EndCol) = 0 Then

                SelectionOnly = False

            End If

        End With

    End If

    If SelectionOnly = False Then

        With ActiveSheet.UsedRange

            StartRow = .Cells(1).Row

            StartCol = .Cells(1).Column

            EndRow = .Cells(.Cells.Count).Row

            EndCol = .Cells(.Cells.Count).Column

        End With

    End If

    Set fso = CreateObject("ADODB.Stream")

    fso.Type = 2 'Specify stream type – we want To save text/string data.

    fso.Charset = "utf-8" 'Specify charset For the source text data.

    fso.Open 'Open the stream And write binary data To the object

    For RowNdx = StartRow To EndRow

        WholeLine = ""

        For ColNdx = StartCol To EndCol

            If Cells(RowNdx, ColNdx).Value = "" Then

                CellValue = ""

            Else

                CellValue = Cells(RowNdx, ColNdx).Value

            End If

            If CellValue = "(blank)" Then

                CellValue = ""

            End If

            CellValue = Enclose & CellValue & Enclose

            WholeLine = WholeLine & CellValue & Sep

        Next ColNdx

        WholeLine = Left(WholeLine, Len(WholeLine) – Len(Sep)) & vbCrLf

        fso.WriteText WholeLine

    Next RowNdx

    fso.SaveToFile FName, 2 'Save binary data To disk

    fso.Close

    MsgBox (RowNdx – 1) & " record(s) exported to " & FName

EndMacro:

    On Error GoTo 0

    Application.ScreenUpdating = True

End Sub

Based on http://stackoverflow.com/questions/59075/save-each-sheet-in-a-workbook-to-separate-csv-files and http://stackoverflow.com/questions/2524703/save-text-file-utf-8-encoded-with-vba

Tags: , ,

No comments yet.

Leave a Reply