將excel導出爲csv的工作VBA UTF8

Question

此主題已得出結論：我是一個初學者，我可以工作 - 如果您需要調整簡單的東西，您可能想要閱讀所有這些在這裏說...

的溶液在這篇文章的底部抄...

原始任務： 這是一個更好的擅長以CSV在UTF8解決方案，我能找到那裏。大多數人想要安裝插件或不必要地使該過程複雜化。其中有很多。

一個問題已經解決。 （如何導出使用的行而不是預定義的數字）

剩下的是調整一些東西。

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 

SOLUTION： （請注意，您可以預先通過用數字替換wkb.UsedRange.Rows.Count定義的行數 - 同樣的柱子，和做其他小的調整應該需要） 如果你想一個預先定義的文件路徑放在空引號後的文件名= 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）。 我還刪除了當前未使用的標籤「誒：」從結束，並添加嵌套：

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