ExcelでCSV出力したファイルが文字化けしていることがありませんか？
ExcelではCSV出力時デフォルトでSJIS出力されるためUTF8の文字コードで入力された文字は化けしてしまいます。
UTF8で出力するマクロを作成したので下のリンクよりダウンロードしてご利用ください。
Introduction of macros for UTF8 output with Excel VBA.
使い方
ブックを開いて出力したいカラム数を入力し、マクロ実行ボタンをクリックするとファイル選択画面が出るのでCSV出力したいブックを選んでください。
OutputCSVforUTF8.xlsm を保存しているフォルダに選択したブック名で拡張子CSVのファイルが作成されます。
作るに当たった経緯
会社でExcelで作ったデータをCSV出力すると文字化けするという相談をされた。
そんな馬鹿なと思い色々と調べたところ、バージョンによりUTF8で出力することがそもそも出来ないものがあるもよう。
出来るにしてもどうもBOM有りでしか出力してくれない事がわかった。
会社によっては最新のExcelではないためどうしようもないらしい。。
まずはUTF8で出力
<excel VBA UTF8出力> で検索する
strFiles = "Sample.csv"
With CreateObject("ADODB.Stream")
.Charset = "UTF-8"
.Open
.WriteText ThisWorkbook.Worksheets(1).Cells(1, 1)
.WriteText ThisWorkbook.Worksheets(1).Cells(1, 2), 1
.SaveToFile strFiles, 2
.Close
End With
出力したcsvをテキストエディタで確認するとBOM有りで出力されていた・・・
UTF8のStream出力でBOM無し
<ADODB.Stream UTF8 BOMなし> で検索する
.Position = 0
.Type = 1
.Position = 3
byteData = .Read
.Close
.Open
.Write byteData
BOM情報分ずらして変数に突っ込んだ後に書き込めと言うことらしい。
変換したいExcelを指定
<Excel vba ファイル選択ダイアログ>で検索する。
<excel vba ファイル選択ダイアログ フォルダ指定>で検索する。
<excel vba ファイル選択ダイアログ フォルダ指定 拡張子指定>で検索する。
ChDir ThisWorkbook.Path
strFiles = Application.GetOpenFilename(FileFilter:="Excelファイル, *.xls;*.xlsx", MultiSelect:=True)これで拡張子が xls xlsx のファイルがフィルターされ、ブックがあるフォルダをカレントフォルダにした状態でダイアログが表示される。
選択されたファイル名の拡張子をCSVにして出力
<excel vba ファイル名 拡張子>で検索する。
<Scripting.FileSystemObject>で検索する。
Set FSO = CreateObject("Scripting.FileSystemObject")
.SaveToFile FSO.getbasename(f) & ".csv", 2シートの最後の行を取得
<excel VBA データの最終行を取得>で検索する。
Y = wb.Worksheets(1).Cells(Rows.Count, 1).End(xlUp).Rowカラムも同様に自動で取得しようか悩んだが、シートの中で指定するようにした。
データ次第で実行する人が想定していないカラム数で出力されてプログラムがおかしいと言われることを避ける為そうした。
VBAで出力した結果とExcel(M365なのでUTF8出力できる)で出力した結果を比較するとダブルクォーテーションとカンマがある場合を考慮しなければいけない様だ。
ダブルクォーテーションとカンマの処理
データを眺めていくと
・カンマのみある
・ ダブルクォーテーションで全体が括られている
・ ダブルクォーテーションとカンマが混在
この3種類の対策を行った方がよさそう、という事で関数にする。
2と3の場合の処理内容は同じだが、出力したCSVを処理する側の仕様で何か対応が変わるかも、と思いこんなコードにしておいた。
Function funReplace(strDmy As String) As String
Dim intMode As Integer
If 0 < InStr(1, strDmy, ",") Then intMode = 1
If 0 < InStr(1, strDmy, """") Then intMode = intMode + 2
Select Case intMode
'文字列に , がある場合
Case "1"
strDmy = """" & strDmy & """"
'文字列に " がある場合
Case "2"
strDmy = """" & Replace(strDmy, """", """""") & """"
'文字列に "と, がある場合
Case "3"
strDmy = """" & Replace(strDmy, """", """""") & """"
End Select
funReplace = strDmy
End Function出来上がり
Sub OutputCSVforUTF8()
Dim Y As Long, X As Long
Dim strFiles As Variant
Dim wb As Workbook
Dim FSO
Dim byteData() As Byte
'このブックがあるフォルダをカレントにする
ChDir ThisWorkbook.Path
'マスクする拡張子指定
strFiles = Application.GetOpenFilename(FileFilter:="Excelファイル, *.xls;*.xlsx", MultiSelect:=True)
If IsArray(strFiles) Then
'対象ファイル名の拡張子をcsvにしたい為Createしておく
Set FSO = CreateObject("Scripting.FileSystemObject")
For Each f In strFiles
Set wb = Workbooks.Open(f)
'最終行を取得
Y = wb.Worksheets(1).Cells(Rows.Count, 1).End(xlUp).Row
X = ThisWorkbook.Worksheets(1).Cells(1, 2)
With CreateObject("ADODB.Stream")
.Charset = "UTF-8"
.Open
For i = 1 To Y
For X = 1 To X - 1
.WriteText funReplace(wb.Worksheets(1).Cells(i, X).Value)
.WriteText ","
Next
'改行付でWrite
.WriteText funReplace(wb.Worksheets(1).Cells(i, X).Value), 1
Next
'BOM情報をスキップする為の処理
.Position = 0
.Type = 1
.Position = 3
byteData = .Read
.Close
.Open
.Write byteData
'開いたブック名.csv で保存する
.SaveToFile FSO.getbasename(f) & ".csv", 2
.Close
End With
wb.Close
Next
Set FSO = Nothing
Else
MsgBox ("ファイルが選択されませんでした")
End If
End Sub
コメント