将 excel 导出到 csv UTF8 的工作 VBA

Question

这个话题已经结束：我是一个完全的初学者，我可以做这个 - 如果你需要调整简单的东西，你可能想阅读这里所说的所有内容......

解决方案复制在本文底部...

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

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

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

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

更新

使用它来删除输出中的尾随逗号。 （见 cmets）

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

我从您的 cmets 中假设您希望每个单元格都用引号括起来并用逗号分隔，包括空白单元格（这是一个普通的 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