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

この文書は読取専用です。文書のソースを閲覧することは可能ですが、変更はできません。もし変更したい場合は管理者に連絡してください。
====== 特定の範囲を指定してCSV出力するVBAマクロ ======

  * WindowsとMacの両対応。ADODB.Streamを使用しているため、参照設定で、Microsoft ActiveX Data Objects x.x Library を追加して下さい。

<code vb>
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
</code>
ユーザ用ツール

サイト用ツール

ページ用ツール
