ユーザ用ツール

サイト用ツール


サイドバー

About

Contents

Materials Link

その他

PR


wiki:vba:tips:001

特定の範囲を指定してCSV出力するVBAマクロ

  • WindowsとMacの両対応。ADODB.Streamを使用しているため、参照設定で、Microsoft ActiveX Data Objects x.x Library を追加して下さい。
Option Explicit 
 
Sub SaveAsCSV() 
 
    If Application.OperatingSystem Like "*Mac*" Then 
        SaveAsCSVForMac 
    Else 
        SaveAsCSVForWin 
    End If 
 
End Sub 
 
Sub SaveAsCSVForWin() 
 
    '============================== 
    ' 使用しているデータ範囲の取得 
    '============================== 
    Dim maxRow As Long 
    Dim startRow As Long 
    Dim maxCol As Long 
    Dim startCol As Long 
 
    '検索対象のセル 
    Dim CsvTop As Range 
    Dim CsvRight As Range 
    Dim CsvButtom As Range 
 
    'セルの検索 
    Set CsvTop = Range("A1:CZ2048").Find(What:="CSV_TOP", LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByRows) 
    Set CsvRight = Range("A1:CZ2048").Find(What:="CSV_RIGHT", LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByRows) 
    Set CsvButtom = Range("A1:CZ2048").Find(What:="CSV_BUTTOM", LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByRows) 
 
   'セルが見つかったかチェック 
    If (CsvTop Is Nothing And CsvRight Is Nothing And CsvButtom Is Nothing) Then 
        MsgBox "出力失敗 セルに CsvTop, CsvRight, CsvButtomの記述がありません" 
    End If 
 
    startRow = CsvTop.Row + 1 
    maxRow = CsvButtom.Row - 1 
    startCol = CsvTop.Column + 1 
    maxCol = CsvRight.Column - 1 
 
 
    '============================== 
    ' ストリームの準備 
    '============================== 
    Dim outStream As ADODB.Stream 
    Set outStream = New ADODB.Stream 
 
    'エンコーディングを指定 
    With outStream 
        .Type = adTypeText 
        .Charset = "UTF-8" 
        .LineSeparator = adLF 
    End With 
    outStream.Open 
 
    '============================== 
    ' ストリームにデータを流し込む 
    '============================== 

    Dim r As Long 
    Dim c As Long 
    Dim line As String 
 
    '1 行ずつ処理 
    For r = startRow To maxRow 
 
        '1 列目はカンマなし 
        line = ActiveSheet.Cells(r, startCol) 
 
        '2 列目以降 
        For c = startCol + 1 To maxCol 
            line = line & "," & ActiveSheet.Cells(r, c) 
        Next 
 
        'r 行目のデータを StroutStre 
        am.WriteText line, adWriteLine 
    Next 
 
    '============================== 
    ' 先頭の BOM を削除 
    '============================== 
    'BOM の分 3 バイトをスキップ 
    outStream.Position = 0 
    outStream.Type = adTypeBinary 
    outStream.Position = 3 
 
    'コピー用のストリーム 
    Dim csvStream As ADODB.Stream 
    Set csvStream = New ADODB.Stream 
 
    'バイナリモードで開く 
    csvStream.Type = adTypeBinary 
    csvStream.Open 
 
    'BOM の後からデータをコピー 
    outStream.CopyTo csvStream 
 
    '============================== 
    ' ストリームのデータを書き出す 
    '============================== 

    Dim fileName As String 
    fileName = ThisWorkbook.Path + "/" + ActiveSheet.Name & ".csv" 
 
    'ファイルに保存 
    csvStream.SaveToFile fileName, adSaveCreateOverWrite 
 
    'ストリームの後始末 
    csvStream.Close 
    outStream.Close 
 
End Sub 
 
 
Sub SaveAsCSVForMac() 
 
    Dim fileName As String 
    Dim fileNo As Integer 
 
    '============================== 
    ' 使用しているデータ範囲の取得 
    '============================== 
    Dim maxRow As Long 
    Dim startRow As Long 
    Dim maxCol As Long 
    Dim startCol As Long 
 
    '検索対象のセル 
    Dim CsvTop As Range 
    Dim CsvRight As Range 
    Dim CsvButtom As Range 
 
 
    'セルの検索 
    Set CsvTop = Range("A1:CZ2048").Find(What:="CSV_TOP", LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByRows) 
    Set CsvRight = Range("A1:CZ2048").Find(What:="CSV_RIGHT", LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByRows) 
    Set CsvButtom = Range("A1:CZ2048").Find(What:="CSV_BUTTOM", LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByRows) 
 
   'セルが見つかったかチェック 
    If (CsvTop Is Nothing And CsvRight Is Nothing And CsvButtom Is Nothing) Then 
        MsgBox "出力失敗 セルに CsvTop, CsvRight, CsvButtomの記述がありません" 
    End If 
 
    startRow = CsvTop.Row + 1 
    maxRow = CsvButtom.Row - 1 
    startCol = CsvTop.Column + 1 
    maxCol = CsvRight.Column - 1 
 
    fileNo = FreeFile 
 
    fileName = ThisWorkbook.Path + "/" + ActiveSheet.Name & ".csv" 
 
    Open fileName For Output As #fileNo 
 
    Dim r As Long 
    Dim c As Long 
    Dim line As String 
 
    '1 行ずつ処理 
    For r = startRow To maxRow 
 
        '1 列目はカンマなし 
        line = ActiveSheet.Cells(r, startCol) 
 
        '2 列目以降 
        For c = startCol + 1 To maxCol 
            line = line & "," & ActiveSheet.Cells(r, c) 
        Next 
 
        'r 行目のデータを StroutStre 
        Print #fileNo, line 
    Next 
 
    Close #fileNo 
 
End Sub 
wiki/vba/tips/001.txt · 最終更新: 2016/05/13 23:10 by step