#06 Excelマクロの使い方、自作ツール紹介【VBA】
元は研究のデータ整理のため、学生のときにVBAを独学で始めました。
プログラミングの入門的にも、使ったことあるExcelでプログラムの動きが見えたこととか配列の考え方とセルが似てたので、いまでは最初がVBAで良かったと思っています。
マクロの使い方と自作したマクロのなかで汎用できるものを紹介します。
コピペで使用できますのでよろしければぜひ。
※すみませんが、マクロの実行に関するエラーは自己責任でお願いします。
VBAの基本
VBA（Excelマクロ）の準備、使い方です。
他の記事・サイトにわかりやすいものが多いので、ここは省略します。
変数を宣言しないといけないのも、最初の勉強にはいいかもですね。
Excelマクロの使い方
マクロ自体は正直、そんなに凝ったものは作っていません。
作成したマクロをリボンに追加したり、クイックアクセスツールバーに追加（Alt系のショートカット）したり、cntlのショートカットに登録して使ったりしています。
あとは基本、マクロは個人用マクロブックに保存して、どのファイルからもアクセスできるようにしています。
小さい作業効率化の積み重ねが大事。
1. 全シートの倍率指定＋A1セル選択
複数シートがあるブックで作業の最後にセルの位置とか倍率がシートごとにぐちゃぐちゃになるのが、個人的に嫌で作りました。
実行すると、以下のように動きます。
1. ダイアログボックスで倍率を入力。
2. 全シートの倍率が入力値に変更され、A1セルを選択した状態に移行。
（表示は一番左のシート）
↑の画像の左上の"✓"のボタンにこのマクロを登録しているので、"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関数を知らず、自作していました。以下を使えばもっと短く書けます。
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 Sub3. 作業ブックの全シート名取得
シートが何10枚とか超えてくると便利です。
人が作った大きいExcelみるときにとりあえず、みたいな使い方もします。
実行すると、以下のように動きます。
1. 操作を始めるダイアログボックスが表示、"OK"で進む。
2. 新しいシートを作成、A1セルから下にシート名を表示
マクロをつくるこだわりとして、スタートはキャンセルして戻れるように、おわりは「あれ？これ終わった？」みたいにならないように、実行の始まりと終わりがわかるように意識しています。
（ソースコード）
全シートを対象とする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 Sub4. フォルダ内の全ファイル名取得
ファイルの一覧をつくるときに使えます。
実行してから、対象フォルダをエクスプローラーから選択して実行されます。
実行すると、以下のように動きます。
1. エクスプローラーが起動、対象とするフォルダを選択。
2. ファイル名を取得したいデータの拡張子をダイアログボックスから入力
3. 新規シートのA1セルから下にファイル名を表示
※ファイル名は表示されない
※名前の取得順序は不明。。
（ソースコード）
一つ前のコードがブック内の全シートを対象とするのに対して、フォルダ内の全ファイルを対象に操作をします。
最初のダイアログボックスからパスを取得→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 Sub5. 拡張子まとめて変換
フォルダ内の拡張子をまとめて変換します。
上書き保存する過激派です。ファイル名を変える操作をしているだけで、ファイル使えなくなる可能性もありますので要注意。
実行すると、以下のように動きます。
1. 操作を始めるダイアログボックスが表示、"OK"で進む。
2. ファイル名を取得したいデータの拡張子をダイアログボックスから入力
3. 対象とするファイルの拡張子を入力
4. 対象とするファイルの変換後の拡張子を入力
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 Sub6. Excelファイルから画像抽出
フォルダ内の全Excelに張り付けられている画像を抽出します。汎用性があって便利です。
ご存じの方も多いと思いますが、 Excelを一度zipファイルにしてから解凍するとmediaのフォルダに画像だけ抽出されるあれをフォルダ内の全Excelに行います。
実行すると、以下のように動きます。
1. ファイル名を取得したいデータの拡張子をダイアログボックスから入力
2. Imageフォルダが作成され、画像が保存される。
例えば、Book1,2で以下のような画像が含まれるExcelがあり、これを一つのフォルダに保存します。
このフォルダに対して、マクロを実行すると、Imageフォルダが生成されます。さらに、その中にExcelのファイルごとにフォルダが生成され、画像が抽出されます。
エクセルのシート数や画像の枚数は何枚でもいけます、たぶん。
（ソースコード）
zipの展開がちょっと苦労しました。
正直、細かいことはわかっていませんが、動作するものをつくることはできます。
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つをよく見ていました。
noteも非常に充実していますね。
以下の記事にもコピペで使えるコードがありました。ありがたい。
書籍
書籍は以下を参考にしていました。
大辞典の方は今KindleUnlimitedで無料でした… 結構高かったのに。
おわり
なんかコード内のシンタックスハイライト微妙ですね。
pythonからのエクセル操作にも慣れていきたいところ。
ChatGPT使ったプログラミングもいろんなことができるんだろうなあと思いつつ。また記事書いてみます。
お時間あれば、以下も見ていってください。
この記事が気に入ったらサポートをしてみませんか？