ExcelVBAでUTF-8のcsvファイルを書き出す
表題の通り。
ADODB.Streamdでは、クローズするときにファイル名を指定するのはしっくりこないな。名前の通りにストリームだから「ファイル名なんて飾りですよ」ののりなのかな。
http://msdn.microsoft.com/library/ja/default.asp?url=/library/ja/jpado260/htm/mdobjstream.aspにあるマニュアルを探し出せるまで満足に実行することもできなかった。
Const SHEETNAME As String = "Sheet1" ' 対象とするシート名
Const STARTROW = 2 ' 開始行
Const LASTCOL = 13 ' 最終列
Private Sub cmdCSVoutput_Click()
Dim excelFiles As Variant
Dim exceiFile As String
Dim csvFile As String
Dim i As Integer
' 複数指定で対象とするファイルを指定
exelfiles = Application.GetOpenFilename(FileFilter:="Microsoft Excelブック,*.xls", MultiSelect:=True)
' キャンセル
If Not IsArray(exelfiles) Then
Exit Sub
End If
For i = 1 To UBound(exelfiles)
' 同じパスで拡張子をcsvへ変更してCSVファイルを書き出す
exceiFile = exelfiles(i)
csvFile = Mid(exceiFile, 1, Len(exceiFile) - 3) + "csv"
csvputput exceiFile, csvFile
Next i
End Sub
'
' 指定されたExcelファイル
'
Private Sub csvputput(ByVal excelFile As String, ByVal csvFile As String)
Dim wb As Workbook
Dim ws As Worksheet ' データがあるシート
Dim lastRow As Long ' 最終行
Dim col As Long ' 現在の対象列
Dim row As Long ' 現在の対象行
Dim buf As String
Dim v As Variant
' 文字コードにUTF-8を指定して書き出すCSVファイルをオープン
Set outStream = CreateObject("ADODB.Stream")
outStream.Open
outStream.Charset = "UTF-8" ' ファイルの文字コード
outStream.LineSeparator = -1 ' CRLF
outStream.Type = 2 ' テキスト
' 指定されたシートを開く
Set wb = Workbooks.Open(excelFile)
Set ws = wb.Worksheets(SHEETNAME)
' 出力するCSVファイルを開く
' ヘッダを飛ばして２行目からを書き出す
lastRow = getLastRow(ws)
For row = STARTROW To lastRow
' １行分のデータを作成
buf = ""
For col = 1 To LASTCOL
buf = buf & ",""" & ws.Cells(row, col) & """"
Next
buf = Mid(buf, 2)
' ファイルへ書き出し 文字コード変換は ADODB.Stream がやってくれる
outStream.WriteText buf, 1
Next
' ファイル名を指定してクローズ
outStream.SaveToFile csvFile, 2
outStream.Close
' Excelを閉じる
wb.Close
End Sub
'
' 指定されたシートの最終行を取得する
'
' 行の各セルに値がなければ無効行と判断する
'
Private Function getLastRow(ws As Worksheet)
Dim i As Long
' シートの末尾から先頭方向へ向かって有効な行がある位置を探す
For i = ws.Cells(65535, 1).End(xlUp).row To 1 Step -1
If isValidRow(ws, i) Then
Exit For
End If
Next
' 最終行を戻り値に設定
getLastRow = i
End Function
'
' 指定された行の値を検査して、一つでも値が入っていれば有効な行と判断する
'
Private Function isValidRow(ws As Worksheet, row As Long)
Dim i As Long
Dim b As Boolean
b = False
For i = 1 To LASTCOL
If ws.Cells(row, i) <> “” Then
b = True
Exit For
End If
Next
isValidRow = b
End Function
トラックバック URI : http://www.akky.org/archives/85/trackback/
コメント (0)
