Excelのマクロ、「VBA」で、特定範囲のデータをCSV出力するマクロを作りました。
ということで、VBAに手を出してみました!
正確にはあまり手を出していなかっただけで、やったことはあるんですが。
VBA、やはり便利ですね。
内容
実際は作ったというより、他サイト様のマクロを改造しただけなのですが……
コチラのコードを流用しました。
元々の動作としては、
- 出力したいセルを範囲選択
- マクロを割り当てたボタンを押す
- 決められたパスに、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のマクロと違って、セルの操作は、まだ名前で直感的に分かりやすいあたりがいい(笑)