Excel VBA:選択した範囲やアクティブセル領域のセルのデータだけをCSV形式でエクスポートするサンプルプログラム

マウスで選択した範囲や、アクティブセル領域(Ctrl + テンキーの"＊"をクリックして選択される範囲、VBAで言うと"CurrentRegion")のセルのデータだけをCSV形式のファイルにエクスポートするプログラムを作成したので覚書しておく。

プログラム実行時には、[名前を付けて保存]ダイアログボックスを表示してCSVファイルの保存先を任意に決められるようにしてある。

マクロの実行から指定して実行するのは少し面倒なので、今回はコマンドバー(CommandBar)をVBAで作成させ、作成した2つのボタンにそれぞれのプログラムを割りつけるようにした。

以下にCSV形式でエクスポートするプログラムとコマンドバーを作成するプログラムを記述。

CSV形式に保存するサンプルプログラム

まず最初にCSV形式に保存するためのプログラムを記述。

各データは、引用符として(")ダブルクォーテーションで括るようになっているが、後述するコードに変更すれば引用符を使わないようにもできる。

Sub SaveCSV()
Dim cellValue, LineData As String, i As Integer, j As Integer
Dim columnValue As Integer, FNo As Long, flg As Integer, SaveFileName
Dim wScriptHost As Object, strInitDir As String
    
    '[名前を付けて保存]ダイアログボックスを表示する処理
    'カレントディレクトリをデスクトップに変更
    Set wScriptHost = CreateObject("WScript.Shell")
    ChDir wScriptHost.SpecialFolders("Desktop")
    
    SaveFileName = Application.GetSaveAsFilename("sample", _
                    "CSVファイル,*.csv")
                    
        '[名前を付けて保存]ダイアログボックスの[キャンセル]が
        'クリックされたら即終了
        If SaveFileName = False Then
            Exit Sub
        End If
    
    'CSVファイルに出力する処理
    'どのボタンがクリックされたかを取得
    flg = Application.Caller(1)
        Select Case flg
            Case 1
                cellValue = Selection.Value
        
            'アクティブセル領域のエクスポートボタンが選択された場合
            'セパレータが含まれるので左からの順番は3番目になる
            Case 3
                cellValue = ActiveCell.CurrentRegion.Value
        End Select
    columnValue = Selection.Columns.Count
    LineData = ""
    '複数行 X 複数列の場合
    If columnValue > 1 Then
        For i = LBound(cellValue, 1) To UBound(cellValue, 1)
            For j = LBound(cellValue, 2) To UBound(cellValue, 2)
                LineData = LineData & """" & cellValue(i, j) & ""","
            Next j
            LineData = Left(LineData, Len(LineData) - 1) + vbCrLf
        Next i
    
    '複数行 X 1列の場合
    ElseIf columnValue = 1 And Selection.Cells.Count <> 1 Then
        For i = LBound(cellValue) To UBound(cellValue)
            LineData = LineData & """" & cellValue(i, 1) & ""","
            LineData = Left(LineData, Len(LineData) - 1) + vbCrLf
        Next i
    
    '1つのセルしか選択されていない場合
    Else
        LineData = """" & cellValue & """"
    End If
    
    FNo = FreeFile
    Open SaveFileName For Output As #FNo
        'ファイルに書き込み
        Print #FNo, LineData
    Close #FNo
End Sub

データを引用符(")ダブルクォーテーションでくくらない場合は、38行目と46行目のコードを変更する。

変更前

LineData = LineData & """" & cellValue(i, j) & ""","

変更後

LineData = LineData & cellValue(i, j) & ","

作成したプログラムをコマンドバーに割り当てるサンプルプログラム

次にこのプログラムをコマンドバーに作ったボタンから実行できるように新たにコマンドバーを作成するプログラムを記述。

VBAでコマンドバー(CommandBar)を操作する方法に関する詳細は以下のサイトを参照。

メニュー バーおよびメニュー項目の追加と変更

learn.microsoft.com

Sub AddCSVExportCmdBar()
Dim Cbar As CommandBar
    On Error Resume Next
        CommandBars("CSVエクスポート").Delete
    Set Cbar = CommandBars.Add(Name:="CSVエクスポート", _
    Position:=msoBarFloating, MenuBar:=False)
        With Cbar
            .Controls.Add Type:=msoControlButton, before:=1
                With .Controls(1)
                    .Style = msoButtonCaption
                    .OnAction = "SaveCSV"
                    .Caption = "選択範囲"
                    .TooltipText = "選択されている範囲をCSV形式でエクスポートします。"
                End With
    
            .Controls.Add Type:=msoControlButton, before:=2
                With .Controls(2)
                    .Style = msoButtonCaption
                    .BeginGroup = True
                    .OnAction = "SaveCSV"
                    .Caption = "アクティブセル領域範囲"
                    .TooltipText = "アクティブセル領域をCSV形式でエクスポートします。"
                End With
 
            .Visible = True
        End With
End Sub

いちいちこのファイルを呼び出さなくてよいので頻繁に利用するのであればアドイン化する。