akky’s log

表題の通り。

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