A Working VBA that exports excel to csv UTF8

Question

This topic has concluded: I'm a total beginner and I can work this - if you need to tweak simple stuff you might want to read all thats been said here...

The solution is copied at the bottom of this post...

Original Task: This is one of the better excel to CSV in UTF8 solutions i was able to find out there. Most either want to install plugins or needlessly complicate the process. And there are many of them.

One issue was already solved. (how to export rows in use instead of pre-defined number)

What remains is to tweak some stuff.

Case Excel
A1=Cat, B1=Dog
A2=empty B2=Empty
A3=Mouse B3=Bird

Current script exports

Cat,Dog

Mouse,Bird

Whats needed is

"Cat","Dog"
,
"Mouse","Bird"

Code:

Public Sub WriteCSV()
Set wkb = ActiveSheet
Dim fileName As String
Dim MaxCols As Integer
fileName = Application.GetSaveAsFilename("", "CSV File (*.csv), *.csv")

If fileName = "False" Then
End
End If

On Error GoTo eh
Const adTypeText = 2
Const adSaveCreateOverWrite = 2

Dim BinaryStream
Set BinaryStream = CreateObject("ADODB.Stream")
BinaryStream.Charset = "UTF-8"
BinaryStream.Type = adTypeText
BinaryStream.Open

For r = 1 To 2444
s = ""
C = 1
While Not IsEmpty(wkb.Cells(r, C).Value)
s = s & wkb.Cells(r, C).Value & ","
C = C + 1
Wend

If Len(s) > 0 Then
s = Left(s, Len(s) - 1)
End If
BinaryStream.WriteText s, 1

Next r

BinaryStream.SaveToFile fileName, adSaveCreateOverWrite
BinaryStream.Close

MsgBox "CSV generated successfully"

eh:

End Sub

SOLUTION: (Note you can pre define the number of rows by replacing wkb.UsedRange.Rows.Count with a number - same with columns, and do other minor adjustments should you need to.) If you want a pre defined file path put in the empty quotes after fileName = Application.GetSaveAsFilename(""

Public Sub WriteCSV()
Set wkb = ActiveSheet
Dim fileName As String
Dim MaxCols As Integer
fileName = Application.GetSaveAsFilename("", "CSV File (*.csv), *.csv")

If fileName = "False" Then
End
End If

Const adTypeText = 2
Const adSaveCreateOverWrite = 2

Dim BinaryStream
Set BinaryStream = CreateObject("ADODB.Stream")
BinaryStream.Charset = "UTF-8"
BinaryStream.Type = adTypeText
BinaryStream.Open

For r = 1 To wkb.UsedRange.Rows.Count
    S = ""
    sep = ""

    For c = 1 To wkb.UsedRange.Columns.Count
        S = S + sep
        sep = ","
        If Not IsEmpty(wkb.Cells(r, c).Value) Then
            S = S & """" & wkb.Cells(r, c).Value & """"
        End If
    Next

    BinaryStream.WriteText S, 1

Next r

BinaryStream.SaveToFile fileName, adSaveCreateOverWrite
BinaryStream.Close

MsgBox "CSV generated successfully"

eh:

End Sub

Answer 1

Use:

For r = 1 To wkb.UsedRange.Rows.Count

Update

Use this to remove the trailing commas in your output. (see comments)

If Len(s) > 0 Then
    s = Left(s, Len(s) - 1)
End If
BinaryStream.WriteText s, 1

Update 2

I hope this will work as you expect. I changed the way the commas are added and added a the variable sep (separator) for that. Maybe you want to declare it in function header. If you have a fixed count of row and you know the count you can replace the wkb.UsedRange.Columns.Count expression. As you see inside quotes you have to quote a quote what makes 4 quotes alltogether (I don't know if this sentence makes sense.) :-)

For r = 1 To wkb.UsedRange.Rows.Count
    s = ""
    sep = ""

    For c = 1 To wkb.UsedRange.Columns.Count
        s = s + sep
        sep = ","
        If Not IsEmpty(wkb.Cells(r, c).Value) Then
            s = s & """" & wkb.Cells(r, c).Value & """"
        End If
    Next

    BinaryStream.WriteText s, 1
Next r

And take a deep breath when you finally did it.

Answer 2

I assume from your comments that you want each cell surrounded by quotes and separated by commas including the blank cells (this is a normal CSV).

The code below uses ForEach to traverse the used range of the spreadsheet.

Public Sub WriteCSV()
Set wkb = ActiveSheet
Dim fileName As String
Dim MaxCols As Integer
fileName = Application.GetSaveAsFilename("", "CSV File (*.csv), *.csv")

If fileName = "False" Then
End
End If

On Error GoTo eh
Const adTypeText = 2
Const adSaveCreateOverWrite = 2

Dim BinaryStream
Set BinaryStream = CreateObject("ADODB.Stream")
BinaryStream.Charset = "UTF-8"
BinaryStream.Type = adTypeText
BinaryStream.Open

                                    '   calculate the last column number
MaxCol = ActiveSheet.UsedRange.Column + ActiveSheet.UsedRange.Columns.Count - 1
S = Chr(34)                         '   double quote

For Each Cell In ActiveSheet.UsedRange ' traverse the used range

    S = S & Cell.Value

    If Cell.Column = MaxCol Then    '   last cell in row

        S = S & Chr(34)             '   close the quotes

        BinaryStream.WriteText S, 1

        S = Chr(34)                 '   start next row with quotes

    Else

        S = S + Chr(34) & "," & Chr(34) ' close the quotes, write comma, open quotes

    End If

Next

BinaryStream.SaveToFile fileName, adSaveCreateOverWrite
BinaryStream.Close

MsgBox "CSV generated successfully"

eh:

End Sub

If you need to have cells containing only numbers without quotes, it will need a little more work.

Answer 3

The current solution (which appears in the OP itself) is great except one thing - it adds a BOM. Here's my solution that also strips the BOM (via https://stackoverflow.com/a/4461250/4829915 ). I've also removed the currently unused label "eh:" from the ending and added nesting:

Sub WriteCSV()
    Set wkb = ActiveSheet
    Dim fileName As String
    Dim MaxCols As Integer
    fileName = Application.GetSaveAsFilename("", "CSV File (*.csv), *.csv")

    If fileName = "False" Then
        End
    End If

    Const adTypeText = 2
    Const adSaveCreateOverWrite = 2
    Const adTypeBinary = 1

    Dim BinaryStream
    Dim BinaryStreamNoBOM
    Set BinaryStream = CreateObject("ADODB.Stream")
    Set BinaryStreamNoBOM = CreateObject("ADODB.Stream")
    BinaryStream.Charset = "UTF-8"
    BinaryStream.Type = adTypeText
    BinaryStream.Open

    For r = 1 To wkb.UsedRange.Rows.Count
        S = ""
        sep = ""

        For c = 1 To wkb.UsedRange.Columns.Count
            S = S + sep
            sep = ","
            If Not IsEmpty(wkb.Cells(r, c).Value) Then
                S = S & """" & wkb.Cells(r, c).Value & """"
            End If
        Next

        BinaryStream.WriteText S, 1
    Next r

    BinaryStream.Position = 3 'skip BOM
    With BinaryStreamNoBOM
        .Type = adTypeBinary
        .Open
        BinaryStream.CopyTo BinaryStreamNoBOM
        .SaveToFile fileName, adSaveCreateOverWrite
        .Close
    End With

    BinaryStream.Close

    MsgBox "CSV generated successfully"

End Sub