Excel便利マクロ（VBA）

学生のときに使っていた個人的に便利なマクロを紹介します．

一度作ってしまえばショートカットボタンにして使えるので便利です．

Active Sheet内の図のx, y軸一括変更

シート内に作成した同じ型の図（グラフ）の軸を変更する場合にダイアログボックスの入力から一括して行うマクロ ModifyScale．

複数図があるとき，選択した図だけ変更でき，何も選択していない場合は全グラフを対象とします． ダイアログボックスはx軸（横軸）の最小→最大，y軸（縦軸）の最小→最大の順で4回出てきます．

使用例

理科年表の水の粘性係数μ，動粘性係数νと温度の関係でサンプルファイル作りました（理科年表プレミアム - コンテンツ表示）．

こんな感じで同じ型の図があるときに，

ショートカットにした ModifyScaleを使って，x，y軸の最小値，最大値をダイアログボックスから順に入力します（例ではx_min=0，x_max=100，y_min=0，y_max=2を入力）．

で，一括変更できます（xは0~120を0~100に，yは0~3を0~2に）．

ショートカットは棒グラフみたいなマークに設定しました．

ソースコード

ModifyScale

Sub ModifyScale()
    
    
    '** アクティブなシート内の選択したグラフのグラフ軸をダイアログボックスから入力して一括で変更するプロシージャ
    '** （選択されていない場合はすべてのグラフを対象）


    Application.ScreenUpdating = False      '画面の更新を抑制（高速化）
    On Error Resume Next                    'エラーを無視
    
    
    Dim x_max, x_min, y_max, y_min As String
    Dim chtobj As ChartObject
    Dim obj, obj2 As Object
    

    Rem x軸の最小値の入力
        Call DataInput(x_min, "x軸の【最小値】を入力して下さい。", "")
        If x_min = "" Then Exit Sub
    Rem x軸の最大値の入力
        Call DataInput(x_max, "x軸の【最大値】を入力して下さい。", "")
        If x_max = "" Then Exit Sub
    Rem y軸の最小値の入力
        Call DataInput(y_min, "y軸の【最小値】を入力して下さい。", "")
        If y_min = "" Then Exit Sub
    Rem y軸の最大値の入力
        Call DataInput(y_max, "y軸の【最大値】を入力して下さい。", "")
        If y_max = "" Then Exit Sub
    
    
    Set obj = Selection
    
    If TypeName(obj) <> "DrawingObjects" Then       '2コ以上のグラフが選択されると"DrawingObjects"を返す -> 選択されたグラフが1コor0コ
        
        If Not ActiveChart Is Nothing Then          '1コの場合
            With ActiveChart
            .Axes(xlCategory).MinimumScale = CDbl(x_min)
            .Axes(xlCategory).MaximumScale = CDbl(x_max)
            .Axes(xlValue).MinimumScale = CDbl(y_min)
            .Axes(xlValue).MaximumScale = CDbl(y_max)
            End With
        Else                                        '0コの場合 -> アクティブシート内全部
            For Each chtobj In ActiveSheet.ChartObjects
                With chtobj.Chart
                    .Axes(xlCategory).MinimumScale = CDbl(x_min)
                    .Axes(xlCategory).MaximumScale = CDbl(x_max)
                    .Axes(xlValue).MinimumScale = CDbl(y_min)
                    .Axes(xlValue).MaximumScale = CDbl(y_max)
                End With
            Next chtobj
        End If
        
    Else                                            '複数コの場合
    
        For Each obj2 In obj
            If TypeName(obj2) = "ChartObject" Then
                With obj2.Chart
                    .Axes(xlCategory).MinimumScale = CDbl(x_min)
                    .Axes(xlCategory).MaximumScale = CDbl(x_max)
                    .Axes(xlValue).MinimumScale = CDbl(y_min)
                    .Axes(xlValue).MaximumScale = CDbl(y_max)
                End With
            End If
        Next obj2
        
    End If
    
End Sub

ブック内全シートの倍率を一括変更 & A1セルを選択

ダイアログボックスから入力した値に全シートの倍率を変更し，左上A1セルを選択した状態にするマクロ MakeDefault （最終的には一枚目のシートを開いた状態に）．
Excelファイルを提出するときにキレイな状態で提出できます．自己満足です．

使用例

先ほどのサンプルブック二枚目に水の密度と温度の関係にシートを追加します（理科年表プレミアム - コンテンツ表示）．

いろいろいじってシートの倍率とか選択セルの位置がバラバラになります．

MakeDefault 使うと（デフォルトで倍率は80が入ってます），

キレイになります．以上です．

ショートカットはパーみたいなマークに設定しました．

さらに...

MakeDefaultToFolder で再帰呼び出しを使って指定したフォルダ内のサブフォルダ内までを対象に全.xlsxファイルの全シートに MakeDefault を行います．
フォルダを対象に一気にキレイにしたいときに便利です．

ソースコード

MakeDefault

Sub MakeDefault()


    '** アクティブなブック内の全シートを指定した倍率にしてA1セルを選択し、
    '** 一枚目のシートを表示するサブプロシージャ


    Application.ScreenUpdating = False      '画面の更新を抑制（高速化）
    On Error Resume Next                    'エラーを無視
    
    Dim zoom As String
    Dim sheet As Object     'ループ中に処理対象となるシートの変数
    
    
    Rem シートの倍率を入力
    Call DataInput(zoom, "シートの倍率を入力", 80)
    If zoom = "" Then Exit Sub
    
    Rem 一番先頭のシートから順にループ処理を行う
    For Each sheet In ActiveWorkbook.Sheets
        sheet.Activate                          '対象のシートをアクティブにする
        ActiveSheet.Range("A1").Select          'シートのA1を選択する
        ActiveWindow.zoom = CInt(zoom)          '拡大倍率を設定する
        ActiveWindow.ScrollColumn = 1           'スクロールを左上に
        ActiveWindow.ScrollRow = 1
    
    Rem 次のシートを処理対象にする
    Next sheet
    
    Rem 一番先頭のシートをアクティブにする
    Sheets(1).Select

End Sub

MakeDefaultToFolder

Sub MakeDefaultToFolder()


    '** 指定したフォルダ内（サブフォルダも）のすべてのExcelファイルにマクロ "MakeDefault" をかけるサブプロシージャ


    Application.ScreenUpdating = False      '画面の更新を抑制（高速化）
    On Error Resume Next                    'エラーを無視


    Dim folderPath As String
    Dim zoom As String
        
    Rem シートの倍率を入力
    Call DataInput(zoom, "シートの倍率を入力", 80)
    If zoom = "" Then Exit Sub
        
    Rem ダイアログボックスから対象フォルダを選択
    With Application.FileDialog(msoFileDialogFolderPicker)
        .Title = "対象フォルダを選択"
      If .Show = 0 Then
         MsgBox "Canceled."
         Exit Sub
      End If
         folderPath = .SelectedItems(1)
    End With
    
    Rem 再帰呼び出しマクロのcall
    Call Call_MakeDefaultToFolder(folderPath, zoom)
    

    MsgBox "Finish!"

End Sub


Sub Call_MakeDefaultToFolder(MyPath As String, MyZoom As String)


    '** 呼び出し用 (再帰呼び出し：RecursiveCall)


    Dim file As String
    Dim sheet As Object
    Dim wb As Workbook
    Dim fso, obj As Object
        
    file = Dir(MyPath & "\" & "*.xlsx")
    
    
    Rem ファイル名が空にならない間繰り返し
    Do While file <> ""

        Set wb = Workbooks.Open(FileName:=MyPath & "\" & file)
    
        Rem 一番先頭のシートから順にループ処理を行う
        For Each sheet In wb.Sheets
            sheet.Activate                          '対象のシートをアクティブにする
            ActiveSheet.Range("A1").Select          'シートのA1を選択する
            ActiveWindow.zoom = CInt(MyZoom)        '拡大倍率を設定する
            ActiveWindow.ScrollColumn = 1           'スクロールを左上に
            ActiveWindow.ScrollRow = 1
        Next sheet
    
        Sheets(1).Select    '一番先頭のシートをアクティブにする
    
        wb.Save             'エクセルファイルを保存して閉じる
        wb.Close
    
        file = Dir()        '2番目以降のファイル名を取得
    
    Loop
    
    
    Rem FileSystemObjectを使ってフォルダーを取得
    Set fso = CreateObject("Scripting.FileSystemObject")
    For Each obj In fso.GetFolder(MyPath).SubFolders
        Call Call_MakeDefaultToFolder(obj.Path, MyZoom)
    Next
    

End Sub

※ダイアログボックスで変数の値（Str型）を入力するサブプロシージャ

上のプログラム内で使ったサブプロシージャDataInput．
引数は
X に入力したい変数
message にダイアログボックスのタイトル
message2 にデフォルトで入力する値（空白も可）
です．

色んな所で使えると思います．

Sub DataInput(X As Variant, message As String, message2 As String)

    '** ダイアログボックスで変数の値(Str型)を入力するサブプロシージャ
    
    Rem        x：変数（文字列型）
    Rem  message：ダイアログボックスのタイトル
    Rem message2：デフォルトの入力文字
    
    Dim flg_if As Boolean
    
    flg_if = False
    Do
        X = InputBox(message, default:=message2)
        If StrPtr(X) = 0 Then       ' キャンセル時に終了
            MsgBox "Canceled.", vbExclamation
            Exit Sub
        ElseIf X = "" Then          '値を入力しないでOKボタンを押した場合，再Loopへ
            MsgBox message, vbExclamation
        ElseIf X <> "" Then
            flg_if = True           '入力があった場合おわり
        End If
    Loop Until flg_if = True
    
End Sub

高速化のため，Application.ScreenUpdating = Falseで画面の更新を制御して，On Error Resume Nextでエラーを無視しています．

おわりに

VBAはネットとか，

できる大事典 Excel VBA 2016/2013/2010/2007 対応 (できる大事典シリーズ)

を参考にしています．

皆さんもとっておきの私用マクロありますか？