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
          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 = “”
                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


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

    On Error GoTo 0
    Application.ScreenUpdating = True

End Sub

Tags: , , ,

No comments yet.

Leave a Reply