#06 Excelマクロの使い方、自作ツール紹介【VBA】

元は研究のデータ整理のため、学生のときにVBAを独学で始めました。

プログラミングの入門的にも、使ったことあるExcelでプログラムの動きが見えたこととか配列の考え方とセルが似てたので、いまでは最初がVBAで良かったと思っています。

マクロの使い方と自作したマクロのなかで汎用できるものを紹介します。
コピペで使用できますのでよろしければぜひ。

※すみませんが、マクロの実行に関するエラーは自己責任でお願いします。

VBAの基本

VBA（Excelマクロ）の準備、使い方です。
他の記事・サイトにわかりやすいものが多いので、ここは省略します。

変数を宣言しないといけないのも、最初の勉強にはいいかもですね。

Excelマクロの使い方

マクロ自体は正直、そんなに凝ったものは作っていません。

作成したマクロをリボンに追加したり、クイックアクセスツールバーに追加（Alt系のショートカット）したり、cntlのショートカットに登録して使ったりしています。

あとは基本、マクロは個人用マクロブックに保存して、どのファイルからもアクセスできるようにしています。

小さい作業効率化の積み重ねが大事。

タブやクイックアクセスツールバーに自作マクロを登録すると便利

1. 全シートの倍率指定＋A1セル選択

複数シートがあるブックで作業の最後にセルの位置とか倍率がシートごとにぐちゃぐちゃになるのが、個人的に嫌で作りました。

実行すると、以下のように動きます。

1. ダイアログボックスで倍率を入力。
2. 全シートの倍率が入力値に変更され、A1セルを選択した状態に移行。
　（表示は一番左のシート）

1. 倍率入力画面

2. 全シートこの状態になる！きれい

↑の画像の左上の"✓"のボタンにこのマクロを登録しているので、"Alt+1”で実行されます。

客先にExcelを提出するときとかにも、きっちり感が出て気に入っています。作ったマクロの中で一番よく使います。
A型だねえといわれます。

（ソースコード）
メイン

Public 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

ダイアログボックスから数値を入力するサブルーチン

Private 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

※当時はInputBox関数を知らず、自作していました。以下を使えばもっと短く書けます。

インプットボックス(InputBox関数)｜VBA入門

2. 選択したセルの塗りつぶし・フォントを"自動"に戻す

実行すると、以下のように動きます。
0.はマクロの実行前です。

0. 対象とするセルを選択（複数もOK）
1. 選択しているセルのフォントを"自動"に、塗りつぶしを"なし"に変更。

これだけです。
ただ、これを"cntl +q"などのショートカットにすると（他の機能と被りにくいので）、なかなか使えます。

Excelはほとんどマウス不要なので、キーボード離れてマウス操作をしないだけでストレスが全然違います。これに限らずですが、マクロを実行すると"戻る"が効かなくなるので注意。

（ソースコード）
マクロの記録を使ってさくっと作りました。

Public Sub QuickClear()

    '** 選択したセルをフォント色「自動」+ 塗りつぶしなしに
    '** cnrl + q
    With Selection.Font
        .ColorIndex = xlAutomatic
        .Bold = False
        .Italic = False
        .Underline = False
        .Strikethrough = False
    End With
    Selection.Interior.ColorIndex = xlNone
    
End Sub

3. 作業ブックの全シート名取得

シートが何10枚とか超えてくると便利です。
人が作った大きいExcelみるときにとりあえず、みたいな使い方もします。

実行すると、以下のように動きます。

1. 操作を始めるダイアログボックスが表示、"OK"で進む。
2. 新しいシートを作成、A1セルから下にシート名を表示

マクロをつくるこだわりとして、スタートはキャンセルして戻れるように、おわりは「あれ？これ終わった？」みたいにならないように、実行の始まりと終わりがわかるように意識しています。

1. スタートのダイアログボックス、OKで進む

2. 新規シートにシート名を列挙

2. 終了の画面、OK押して終わり

（ソースコード）
全シートを対象とするForEachはループの中身を変えれば、全シートの同じ位置に書き込みとか、同じ位置のセルの内容を拾うとか、印刷範囲を設定するとか、いろんなことに応用できます。

Public Sub GetSheetNames()

    Rem 開いているエクセルのシート名一覧を取得（アクティブなシートに書き込み）
    
    Dim vbm As VbMsgBoxResult
    Dim mysheet As Worksheet
    Dim myRow As Long
    
    vbm = MsgBox("シート名一覧を取得します。", vbOKCancel)
    If vbm = vbCancel Then
        MsgBox "Canceled.", vbExclamation
        Application.DisplayAlerts = False       '保存時の表示off
        Exit Sub
    End If
    
    Worksheets.Add After:=Worksheets(Worksheets.count)
    myRow = 1
    For Each mysheet In Worksheets
        ActiveSheet.Cells(myRow, 1).Value = mysheet.Name
        myRow = myRow + 1
    Next
    
    MsgBox "Finished."
    
End Sub

4. フォルダ内の全ファイル名取得

ファイルの一覧をつくるときに使えます。
実行してから、対象フォルダをエクスプローラーから選択して実行されます。

実行すると、以下のように動きます。

1. エクスプローラーが起動、対象とするフォルダを選択。
2. ファイル名を取得したいデータの拡張子をダイアログボックスから入力
3. 新規シートのA1セルから下にファイル名を表示

対象とするフォルダの例、5つのエクセルを入れてます。

1. エクスプローラーから対象とするフォルダを選択
※ファイル名は表示されない

2. 取得したデータの拡張子を指定、ワイルドカード*もOK

3.新規シートにファイル名を取得
※名前の取得順序は不明。。

（ソースコード）
一つ前のコードがブック内の全シートを対象とするのに対して、フォルダ内の全ファイルを対象に操作をします。

最初のダイアログボックスからパスを取得→DoWhileで全ファイルの操作の連携は相当応用が利きます。まとめて操作してなんぼ。

Public Sub GetFileName()

    Rem フォルダ内の指定した拡張子のファイル名一覧を取得

    Dim Path As String
    Dim ext As String
    Dim buf As String
    Dim cnt As Long
    
    With Application.FileDialog(msoFileDialogFolderPicker)
        .Title = "対象ファイルの入ったフォルダを選択"
        .Show
        Path = .SelectedItems(1)
    End With
    
    ext = InputBox("ファイル名を取得する拡張子を入力してください。" & vbNewLine & "（「.」は不要）", "フォルダ内指定した拡張子のファイル名一覧を取得", "xls*")
    If ext = "" Then
        MsgBox "Canceled."
        Exit Sub
    End If
    
    Worksheets.Add After:=Worksheets(Worksheets.count)
    buf = Dir(Path & "\" & "*." & ext)
    Do While buf <> ""
        cnt = cnt + 1
        Cells(cnt, 1) = buf
        buf = Dir()
    Loop
    
    MsgBox "Finished."
    
End Sub

5. 拡張子まとめて変換

フォルダ内の拡張子をまとめて変換します。
上書き保存する過激派です。ファイル名を変える操作をしているだけで、ファイル使えなくなる可能性もありますので要注意。

実行すると、以下のように動きます。

1. 操作を始めるダイアログボックスが表示、"OK"で進む。
2. ファイル名を取得したいデータの拡張子をダイアログボックスから入力
3. 対象とするファイルの拡張子を入力
4. 対象とするファイルの変換後の拡張子を入力
5. 拡張子を変換して上書き保存

1. スタート画面

2. エクスプローラーから対象とするフォルダを選択
※ファイル名は表示されない

3. 対象とする拡張子を指定 

4. 変換後の拡張子を指定

5. 変換前
↓
↓

5. マクロ実行後（変換後）

（ソースコード）
これも、ここまでコードの組み合わせでほぼできます。

Public Sub ConvertExtension()
    
  Rem 対象フォルダ内の指定の拡張子を任意の拡張子に変更
    
    Dim vbm As VbMsgBoxResult
    Dim oldExt As String
    Dim newExt As String
    Dim saveDir As String
    Dim oldFName As String
    Dim newFName As String
    
    vbm = MsgBox("対象フォルダ内の拡張子を変更します。" & vbNewLine & "（データは上書きされます）", vbOKCancel)
    If vbm = vbCancel Then
        MsgBox "Canceled.", vbExclamation
        Application.DisplayAlerts = False       '保存時の表示off
        Exit Sub
    End If

    With Application.FileDialog(msoFileDialogFolderPicker)
        .Title = "対象フォルダを選択"
        If .Show = 0 Then
            MsgBox "Canceled.", vbExclamation
            Exit Sub
        End If
        saveDir = .SelectedItems(1) & "\\"
    End With

    oldExt = InputBox("変更前の拡張子を入力してください。" & vbNewLine & " （「.」は不要 ） ", "変更前の拡張子を入力（データは上書きされます）", "txt")
    If oldExt = "" Then
        MsgBox "Canceled."
        Exit Sub
    End If
    
    newExt = InputBox("変更後の拡張子を入力してください。" & vbNewLine & " （「.」は不要 ）", "変更後の拡張子を入力（データは上書きされます）", "csv")
    If newExt = "" Then
        MsgBox "Canceled."
        Exit Sub
    End If


    oldFName = Dir(saveDir & "*" & oldExt)
    
    Do While Len(oldFName) <> 0
        oldFName = saveDir & oldFName
        newFName = _
            Left(oldFName, Len(oldFName) - Len(oldExt)) & newExt
        
        FileCopy oldFName, newFName
        Kill oldFName
        oldFName = Dir()
    Loop
    
    MsgBox "Finished."
    
End Sub

6. Excelファイルから画像抽出

フォルダ内の全Excelに張り付けられている画像を抽出します。汎用性があって便利です。

ご存じの方も多いと思いますが、 Excelを一度zipファイルにしてから解凍するとmediaのフォルダに画像だけ抽出されるあれをフォルダ内の全Excelに行います。

Excel内の画像を一括で抽出して保存する方法

実行すると、以下のように動きます。

1. ファイル名を取得したいデータの拡張子をダイアログボックスから入力
2. Imageフォルダが作成され、画像が保存される。

例えば、Book1,2で以下のような画像が含まれるExcelがあり、これを一つのフォルダに保存します。

対象フォルダ内に保存する画像ありExcelの例

対象フォルダ内に保存する画像ありExcelの例（フォルダの中身）

このフォルダに対して、マクロを実行すると、Imageフォルダが生成されます。さらに、その中にExcelのファイルごとにフォルダが生成され、画像が抽出されます。

Imageフォルダと各ファイル名のフォルダが生成

フォルダに画像が保存される。
エクセルのシート数や画像の枚数は何枚でもいけます、たぶん。

（ソースコード）
zipの展開がちょっと苦労しました。
正直、細かいことはわかっていませんが、動作するものをつくることはできます。

【VBA】ZIP（圧縮）ファイルを自動的に展開（解凍）する方法-PowerShellコマンド-【VBA】ZIP（圧縮）ファイルを自動的に展開（解凍）する方法-PowerShellコマンド-

Sub SaveImageForExcel()

    Rem 指定したフォルダ内のExcelの画像をImageフォルダ内に保存する。
    
    'Application.ScreenUpdating = False
    
    Dim targetPath, imagePath, destPath As String
    Dim targetFile As String
    Dim oldExt, newExt As String
    Dim newName As String
    Dim zipFile As String
    Dim psCommand As String 'PowerShellのコマンドレット組み立て
    Dim wsh As Object 'Shellオブジェクト
    Dim FSO As Object
    Dim result As Integer 'PowerShellのコマンドレット実行結果
    
    With Application.FileDialog(msoFileDialogFolderPicker)
        .Title = "対象エクセルの入ったフォルダを選択"
        .Show
        targetPath = .SelectedItems(1)
    End With
    
    Rem 保存用フォルダ作成
    imagePath = targetPath & "\" & "Image"
    If Dir(imagePath, vbDirectory) = "" Then MkDir imagePath
    
    targetFile = Dir(targetPath & "\" & "*.xls*")
    Do While targetFile <> ""
                      
        Rem 拡張子をzipに変換したデータをImageフォルダに保存
        oldExt = "xlsx"
        newExt = "zip"
        newName = Left(targetFile, Len(targetFile) - Len(oldExt) - 1) '拡張子変換後のファイル名
        zipFile = imagePath & "\" & newName & "." & newExt
        FileCopy targetPath & "\" & targetFile, zipFile 'zipをImageへ保存
        
        Rem zipを展開
        '展開用フォルダ作成(ハイフンでエラー?)
        destPath = imagePath & "\" & newName
        MkDir destPath
        '実行するPowerShellのコマンドレットを組み立て
        psCommand = "powershell -NoProfile -ExecutionPolicy Unrestricted Expand-Archive -Path " & zipFile & " -DestinationPath " & destPath ' & "-Force"
        'Shellオブジェクトを作成する
        Set wsh = CreateObject("WScript.Shell")
        'PowerShellのコマンドレットを実行
        result = wsh.Run(Command:=psCommand, WindowStyle:=0, WaitOnReturn:=True)
        Set wsh = Nothing
        Kill zipFile
              
        Rem \xl\mediaを各フォルダに移動、名前をExcelと合わせる
        Set FSO = CreateObject("Scripting.FileSystemObject")
        FSO.MoveFolder destPath & "\xl\media", imagePath & "\media"
        Call FSO.DeleteFolder(destPath, True) ' 指定したパスのフォルダを削除
        Set FSO = Nothing
        Name imagePath & "\media" As destPath
        
        targetFile = Dir()
    Loop
    
    
    MsgBox "Finished."

End Sub

参考サイト

基本は困ったら、都度ネット検索で大抵の事はわかります。主に以下の2つをよく見ていました。

ExcelマクロVBA入門編｜エクセルの神髄

Office TANAKA - Excel VBA

noteも非常に充実していますね。
以下の記事にもコピペで使えるコードがありました。ありがたい。

moimoi｜エクセルで事務を楽にするプログラマー｜note

書籍

書籍は以下を参考にしていました。
大辞典の方は今KindleUnlimitedで無料でした… 結構高かったのに。

Excel VBAのプログラミングのツボとコツがゼッタイにわかる本[第2版]

(サンプルファイル・無料電子版付)できる大事典 Excel VBA 2019/2016/2013&Microsoft 365

Kindle Unlimitedにサインアップして無料体験に登録する

おわり

なんかコード内のシンタックスハイライト微妙ですね。
pythonからのエクセル操作にも慣れていきたいところ。

ChatGPT使ったプログラミングもいろんなことができるんだろうなあと思いつつ。また記事書いてみます。

お時間あれば、以下も見ていってください。