【Excel VBA】特定範囲のデータをCSV出力するマクロ

Excelのロゴ

Excelのマクロ、「VBA」で、特定範囲のデータをCSV出力するマクロを作りました。

ということで、VBAに手を出してみました！

正確にはあまり手を出していなかっただけで、やったことはあるんですが。

VBA、やはり便利ですね。

内容
解説
- searchBlank関数
- 元の関数の改造
あとがき

内容

実際は作ったというより、他サイト様のマクロを改造しただけなのですが……

コチラのコードを流用しました。

www.excel-excel.com

元々の動作としては、

出力したいセルを範囲選択
マクロを割り当てたボタンを押す
決められたパスに、CSVとテキストを出力

という感じでした。

それがコチラ。

Private Sub CommandButton1_Click()
    Dim sname As String
    Dim rng As String
        
    '選択範囲のセルアドレス
    rng = Selection.Address
    'シート名
    sname = ActiveSheet.Name
    '新しいシートを追加し、選択範囲をコピー
    Worksheets(sname).Range(rng).Copy Destination:=Worksheets.Add.Range("A1")
    '新しいブックを作成し、そこにシートを移動する
    ActiveSheet.Move
    '上書きのメッセージを表示させない
    Application.DisplayAlerts = False
    'CSV形式でファイル保存
    ActiveWorkbook.SaveAs Filename:="c:\test.csv", FileFormat:=xlCSV
    'テキスト形式でファイル保存
    ActiveWorkbook.SaveAs Filename:="c:\test.txt", FileFormat:=xlCurrentPlatformText
    '保存せずに閉じる
    ActiveWorkbook.Close savechanges:=False
    'メッセージ表示を戻す
    Application.DisplayAlerts = True
    
End Sub

<span style="font-size: 80%">引用：http://www.excel-excel.com/tips/vba_198.html</span>

それを今回自分用に、このようにカスタムしました。

テキスト形式での出力の廃止
特定のセルに書かれたファイル名で出力
特定のセル範囲について、データ行数分をCSV化して出力

' 空セルの検索
' 対象セルから行検索を行い、空セルの行番号を返す
Private Function searchBlank(ByVal startRow As Integer, ByVal col As Integer)
    Dim cnt As Integer
    cnt = 0
    
    ' 検索ループ
    Do While Cells(startRow + cnt, col) <> ""
        cnt = cnt + 1
    Loop
    
    ' return EOFセルの行番号
    searchBlank = (startRow + cnt)
End Function

' custom
Public Sub CsvOutput4DataDefineTable()
    Dim sname As String
    Dim rng As String
    Dim fpath As String
    Dim fname As String
    
    Dim startRow, startCol, endRow, endCol As Integer
    startRow = 5
    startCol = 12
    endRow = searchBlank(startRow, startCol) - 1
    endCol = 23
    
    ' ファイル名取得
    fname = Cells(2, 13)
    ' パス
    fpath = "C:\Output\" & fname

        
    '選択範囲のセルアドレス
    'rng = Selection.Address
    rng = Cells(startRow, startCol).Address & ":" & Cells(endRow, endCol).Address
    'シート名
    sname = ActiveSheet.Name
    '新しいシートを追加し、選択範囲をコピー
    Worksheets(sname).Range(rng).Copy Destination:=Worksheets.Add.Range("A1")
    '新しいブックを作成し、そこにシートを移動する
    ActiveSheet.Move
    '上書きのメッセージを表示させない
    Application.DisplayAlerts = False
    'CSV形式でファイル保存
    ActiveWorkbook.SaveAs Filename:=fpath, FileFormat:=xlCSV
    '保存せずに閉じる
    ActiveWorkbook.Close savechanges:=False
    'メッセージ表示を戻す
    Application.DisplayAlerts = True
    
End Sub

解説

要所要所で解説をします。

searchBlank関数

今回「searchBlank」という関数を作成しました。

この関数は、引数であるセルの行列番号を指定します。

そのセルから下に検索していき、「空のセルを発見するまで」動きます。

完了すると、空のセルがあった「行番号」を返します。

元の関数の改造

今回「CommandButton1_Click」という名前を「CsvOutput4DataDefineTable」に変えました。

なんとなく意味に沿った感じに変更です(笑)

初めのこの箇所で、パスの作成をしています。

今回作業していたファイルに、出力ファイル名が書かれていたのが「M2セル」なので、
「2行目, 13列目」を指定しています。

そのセルで取得した名前を「C:\Output\」というフォルダにくっつけて、出力パスを作成しています。

    ' ファイル名取得
    fname = Cells(2, 13)
    ' パス
    fpath = "C:\Output\" & fname

この箇所で、参照するセル範囲を設定しています。

startRow, startColが、見始める行列番号。
endRow, endColが、終端の行列番号です。

なので、endRow以外固定にして、こいつは作成した関数で値を取得しています。

searchBlank関数は、空セルの行番号を返すので「-1」して、最終セルに番号を合せています。

    Dim startRow, startCol, endRow, endCol As Integer
    startRow = 5
    startCol = 12
    endRow = searchBlank(startRow, startCol) - 1
    endCol = 23

次にrng変数です。

以前はこの変数に、選択セル範囲のアドレスを入れていました。

なので、こちらに今回指定した範囲のアドレスを作って入れてあげます。
データが10行目までだった場合、「$L$5:$W$10」みたいな感じになります。

    '選択範囲のセルアドレス
    'rng = Selection.Address
    rng = Cells(startRow, startCol).Address & ":" & Cells(endRow, endCol).Address

あとはもともとの機能を使って、勝手に出力してもらうだけです。

ちなみに今回テキスト出力は不要なので

    'テキスト形式でファイル保存
    ActiveWorkbook.SaveAs Filename:="c:\test.txt", FileFormat:=xlCurrentPlatformText

は削除しています。

あとがき

久しぶりにVBAに手を出しましたが、これはこれで楽でいいですね。

数式よりもプログラムよりで、大きな作業が一気にできます。

そしてOutlookのマクロと違って、セルの操作は、まだ名前で直感的に分かりやすいあたりがいい(笑)

lisz-works

プログラミングと興味を貴方に

【Excel VBA】特定範囲のデータをCSV出力するマクロ

内容

解説

searchBlank関数

元の関数の改造

あとがき

© 2017 lisz-works