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

<强>更新

使用此选项删除输出中的尾随逗号。（见评论）

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）。我还删除了当前未使用的标签＆＃34; eh：＆＃34;从结尾和添加嵌套：

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

一个工作VBA，可以将excel导出到csv UTF8

3 个答案: