可以将Excel导出到csv UTF8的工作VBA

Question

这个主题已经结束：我是一个初学者，我可以解决这个问题-如果您需要调整简单的内容，则可能需要阅读这里所说的所有内容...

解决方案复制在这篇文章的底部。

原始任务：这是我能够在那里找到的UTF8解决方案中CSV更好的Excel之一。 大多数人要么想要安装插件，要么不必要地使过程复杂化。 而且有很多。

一个问题已经解决。 （如何导出正在使用的行而不是预定义的行）

剩下的就是调整一些东西。

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

当前脚本导出

猫狗

老鼠，鸟

需要的是

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

码：

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

解决方案：（请注意，您可以通过将wkb.UsedRange.Rows.Count替换为数字来预定义行数-与列相同，并应进行其他较小的调整。）如果要放入预定义的文件路径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

采用：

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

更新资料

使用此命令删除输出中的尾部逗号。 （看评论）

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

更新2

我希望这会如您所愿。 我更改了添加逗号的方式，并为此添加了一个变量sep （分隔符）。 也许您想在函数头中声明它。 如果您有固定的行数，并且知道该数，则可以替换wkb.UsedRange.Columns.Count表达式。 正如您在引号内看到的那样，您必须引述一个引号，这使4个引号加在一起（我不知道这句话是否有意义。）:-)

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

终于做完之后，请深呼吸。

Answer 2

我从您的评论中假设，您希望每个单元格都用引号引起来，并用逗号分隔，包括空白单元格（这是正常的CSV）。

下面的代码使用ForEach遍历电子表格的使用范围。

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

如果您需要仅包含不带引号的数字的单元格，则需要做更多的工作。

Answer 3

当前的解决方案（出现在OP本身）很棒，除了一件事-它添加了BOM。 这是我的解决方案，它也剥离了BOM（通过https://stackoverflow.com/a/4461250/4829915 ）。 我还从结尾处删除了当前未使用的标签“ eh：”，并添加了嵌套功能：

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