【Excel】オートシェイプを自動挿入するマクロを作ってもらった話
お疲れ様です。
パソコンでExcel仕事している人、多いと思います。
最近、他部署の人からの相談でオートシェイプ（四角とか丸とかの物体のやつ）を大量に使うのでどうにか効率の良い方法はないか？というざっくりした相談をもらいました。
個人的に仕事で生成AIを使用していたので、どうせなら「オートシェイプを自動で挿入するマクロでも組んでみるか」と思い、マクロ、組んでもらいました。
ただ、このマクロは結果から言うとその相談者の方には提供してません。マクロをわざわざ入れるより、別シートに原本的なオートシェイプを設置してコピーして使った方が良いと思い、そちらを提案しました。相談者の方もその方が楽かな、とのことでした。
そのため、この記事では生成してもらったマクロの埋葬記事になります。生成はGoogle AI StudioのGeimini 2.5 Proになります。
1.マクロの構成
相談者の使用状況としては7つほどパターンがあるオートシェイプを使い回しており使用の都度シートをコピーして整えていました。
そのため、①サイズ、②色、③形、④数の指定が必要かと考え、①から④の順で各々任意のものを入力→オートシェイプ挿入という流れを組むように指示しました。
2.プロンプト
まずはざっくり以下のプロンプトで指示。ほぼこれだけでも形になるので生成AIの進化って目まぐるしいと驚嘆しますね…
指定したサイズ（cm）、色（赤、青、黄色等）、形（丸or四角）、数のオートシェイプを挿入するマクロを組んでほしい。
その後、以下のプロンプトを追加し、結果4回ほど加筆修正してもらってます。
・オートシェイプの線の色は指定した色と同色であること。
・オートシェイプにテキストを入力したいので2行分テキスト入力を追加。（テキスト入力がない場合はそのまま空欄とする）
・挿入位置が固定です。例えばアクティブセルの位置から挿入したい場合で調整してください。
・縦横それぞれ指定したいので入力を縦⇒横の順で入力できるように修正してください。
3.生成物（コード）
最終的な生成物は以下のコードになります。
Sub InsertCustomShapes_V4()
' 変数宣言
Dim strHeightCM As String ' 縦のサイズ入力用
Dim strWidthCM As String ' 横のサイズ入力用
Dim strColorName As String
Dim strShapeType As String
Dim strCount As String
Dim strTextLine1 As String ' テキスト入力用 (1行目)
Dim strTextLine2 As String ' テキスト入力用 (2行目)
Dim dblHeightPoint As Double ' 縦のサイズ (ポイント)
Dim dblWidthPoint As Double ' 横のサイズ (ポイント)
Dim lngColorRGB As Long
Dim msoShapeTypeVal As MsoAutoShapeType
Dim intCount As Integer
Dim i As Integer
Dim shp As Shape
Dim ws As Worksheet
Dim sngLeft As Single
Dim sngTop As Single
Dim sngOffset As Single ' シェイプ間の間隔
Dim sngInitialLeft As Single ' 最初のシェイプの左端位置（改行用）
' --- 初期設定 ---
Set ws = ActiveSheet ' アクティブシートを対象とする
sngOffset = 10 ' シェイプ間の間隔 (ポイント)
' アクティブセルの位置を開始位置とする
If TypeName(Selection) = "Range" Then ' 選択がセルの場合のみ
sngInitialLeft = ActiveCell.Left
sngLeft = ActiveCell.Left
sngTop = ActiveCell.Top
Else
' 選択がセルでない場合は、シートの左上 (A1セルの左上あたり) をデフォルトとする
sngInitialLeft = ws.Cells(1, 1).Left
sngLeft = ws.Cells(1, 1).Left
sngTop = ws.Cells(1, 1).Top
MsgBox "アクティブセルが特定できませんでした。シートの左上から挿入します。", vbInformation
End If
' --- ユーザー入力 ---
' 1a. 縦のサイズ入力 (cm)
strHeightCM = InputBox("挿入するオートシェイプの【縦のサイズ】をcmで入力してください。" & vbCrLf & _
"(例: 2.5)", "縦サイズ指定 (cm)")
If strHeightCM = vbNullString Then Exit Sub ' キャンセル時
If Not IsNumeric(strHeightCM) Or CDbl(strHeightCM) <= 0 Then
MsgBox "縦のサイズは0より大きい数値を入力してください。", vbExclamation, "入力エラー"
Exit Sub
End If
dblHeightPoint = Application.CentimetersToPoints(CDbl(strHeightCM))
' 1b. 横のサイズ入力 (cm)
strWidthCM = InputBox("挿入するオートシェイプの【横のサイズ】をcmで入力してください。" & vbCrLf & _
"(例: 3.0)", "横サイズ指定 (cm)")
If strWidthCM = vbNullString Then Exit Sub ' キャンセル時
If Not IsNumeric(strWidthCM) Or CDbl(strWidthCM) <= 0 Then
MsgBox "横のサイズは0より大きい数値を入力してください。", vbExclamation, "入力エラー"
Exit Sub
End If
dblWidthPoint = Application.CentimetersToPoints(CDbl(strWidthCM))
' 2. 色入力
strColorName = InputBox("挿入するオートシェイプの色を入力してください。" & vbCrLf & _
"(例: 赤, 青, 黄, 緑, 黒, 白, オレンジ, 紫, ピンク など)", "色指定")
If strColorName = vbNullString Then Exit Sub ' キャンセル時
If strColorName = "" Then
MsgBox "色名を入力してください。", vbExclamation, "入力エラー"
Exit Sub
End If
' 色名に基づいてRGB値を設定
Select Case LCase(Trim(strColorName)) '小文字に変換して比較
Case "赤", "red"
lngColorRGB = RGB(255, 0, 0)
Case "青", "blue"
lngColorRGB = RGB(0, 0, 255)
Case "黄", "黄色", "yellow"
lngColorRGB = RGB(255, 255, 0)
Case "緑", "green"
lngColorRGB = RGB(0, 128, 0) '濃い緑
Case "黒", "black"
lngColorRGB = RGB(0, 0, 0)
Case "白", "white"
lngColorRGB = RGB(255, 255, 255)
Case "オレンジ", "orange"
lngColorRGB = RGB(255, 165, 0)
Case "紫", "purple"
lngColorRGB = RGB(128, 0, 128)
Case "ピンク", "pink"
lngColorRGB = RGB(255, 192, 203)
' 必要に応じて他の色を追加してください
Case Else
On Error Resume Next ' RGB文字列 ("255,0,0"など) を試す
Dim rgbParts As Variant
rgbParts = Split(strColorName, ",")
If UBound(rgbParts) = 2 And IsNumeric(Trim(rgbParts(0))) And IsNumeric(Trim(rgbParts(1))) And IsNumeric(Trim(rgbParts(2))) Then
lngColorRGB = RGB(CInt(Trim(rgbParts(0))), CInt(Trim(rgbParts(1))), CInt(Trim(rgbParts(2))))
If Err.Number <> 0 Then ' RGB値として不正な場合
MsgBox "指定された色「" & strColorName & "」は定義されていません。RGB値(例: ""255,0,0"")で指定するか、定義済みの色名を使用してください。" & vbCrLf & _
"デフォルトの赤色で作成します。", vbInformation, "色指定エラー"
lngColorRGB = RGB(255, 0, 0) ' デフォルト色
End If
Else
MsgBox "指定された色「" & strColorName & "」は定義されていません。" & vbCrLf & _
"デフォルトの赤色で作成します。", vbInformation, "色指定エラー"
lngColorRGB = RGB(255, 0, 0) ' デフォルト色
End If
On Error GoTo 0
End Select
' 3. 形入力
strShapeType = InputBox("挿入するオートシェイプの形を入力してください。" & vbCrLf & _
"(丸 または 四角)", "形指定")
If strShapeType = vbNullString Then Exit Sub ' キャンセル時
Select Case Trim(strShapeType)
Case "丸", "円"
msoShapeTypeVal = msoShapeOval
Case "四角", "正方形", "長方形" '「長方形」も追加
msoShapeTypeVal = msoShapeRectangle
Case Else
MsgBox "形は「丸」または「四角」で指定してください。", vbExclamation, "入力エラー"
Exit Sub
End Select
' 4. 数入力
strCount = InputBox("挿入するオートシェイプの数を入力してください。" & vbCrLf & _
"(例: 3)", "数指定")
If strCount = vbNullString Then Exit Sub ' キャンセル時
If Not IsNumeric(strCount) Or CInt(strCount) <= 0 Or InStr(strCount, ".") Then
MsgBox "数は1以上の整数を入力してください。", vbExclamation, "入力エラー"
Exit Sub
End If
intCount = CInt(strCount)
' 5. テキスト入力 (1行目)
strTextLine1 = InputBox("オートシェイプに入力するテキスト (1行目) を入力してください。" & vbCrLf & _
"(何も入力しない場合は空欄になります)", "テキスト入力 (1行目)")
' キャンセルボタンは考慮しない (空欄として扱う)
' 6. テキスト入力 (2行目)
strTextLine2 = InputBox("オートシェイプに入力するテキスト (2行目) を入力してください。" & vbCrLf & _
"(何も入力しない場合は空欄になります)", "テキスト入力 (2行目)")
' キャンセルボタンは考慮しない (空欄として扱う)
' --- オートシェイプ挿入処理 ---
Application.ScreenUpdating = False ' 画面描画を停止して処理を高速化
For i = 1 To intCount
' シェイプを挿入 (指定された縦横のサイズで)
Set shp = ws.Shapes.AddShape(msoShapeTypeVal, sngLeft, sngTop, dblWidthPoint, dblHeightPoint) ' Width, Height の順
' 書式設定
With shp
' 塗りつぶし
.Fill.Visible = msoTrue
.Fill.Solid
.Fill.ForeColor.RGB = lngColorRGB
' 線 (枠線) - 塗りつぶしと同色にする
.Line.Visible = msoTrue
.Line.ForeColor.RGB = lngColorRGB ' 塗りつぶしと同色
.Line.Weight = 1 ' 枠線の太さ (ポイント)
' テキストフレームの設定
If Trim(strTextLine1 & strTextLine2) <> "" Then ' テキストが入力されている場合のみ設定
With .TextFrame2
.TextRange.Characters.Text = strTextLine1 & IIf(strTextLine1 <> "" And strTextLine2 <> "", vbCrLf, "") & strTextLine2
.VerticalAnchor = msoAnchorMiddle ' 上下中央揃え
.TextRange.ParagraphFormat.Alignment = msoAlignCenter ' 水平中央揃え
.TextRange.Font.Size = 9 ' フォントサイズ (適宜調整してください)
' テキストの色を自動調整 (背景色に応じて白または黒)
Dim r As Integer, g As Integer, b As Integer
r = lngColorRGB Mod 256
g = (lngColorRGB \ 256) Mod 256
b = (lngColorRGB \ 65536) Mod 256
If (r * 0.299 + g * 0.587 + b * 0.114) < 128 Then ' 明るさの計算 (簡易版)
.TextRange.Font.Fill.ForeColor.RGB = RGB(255, 255, 255) ' 背景が暗い場合は白文字
Else
.TextRange.Font.Fill.ForeColor.RGB = RGB(0, 0, 0) ' 背景が明るい場合は黒文字
End If
.WordWrap = msoTrue ' テキストを折り返す
End With
End If
End With
' 次のシェイプの挿入位置を更新
sngLeft = sngLeft + dblWidthPoint + sngOffset ' 横幅を使って次の左位置を計算
' シートの右端近くに来たら改行 (アクティブウィンドウの表示可能幅を基準)
If sngLeft + dblWidthPoint > Application.ActiveWindow.UsableWidth * 0.95 Then
sngLeft = sngInitialLeft ' 改行時は最初のシェイプの左端位置に戻す
sngTop = sngTop + dblHeightPoint + sngOffset ' 高さとオフセット分、下に移動
End If
Next i
Application.ScreenUpdating = True ' 画面描画を再開
MsgBox intCount & "個の「" & strShapeType & "」を挿入しました。", vbInformation, "完了"
' オブジェクト変数の解放
Set shp = Nothing
Set ws = Nothing
End Sub4.実際の画面
・起動→挿入画面はこんな感じです。
5.使用時の想定
まぁ大層なマクロを組んでもらって大変恐縮なんですが使用時なんて「ほぼ無い」かと思います…
オートシェイプなんて1個作ってしまえばそれをコピーすればいいわけで、様々な形を入れたい場合はその都度入れなきゃいけないので同じ形のものを多く入れることってあります？笑
6.終わりに
近年、DX化をしなければいけない風潮と世界的に生成AIが普及してきています。しかし、私が勤めているような地方の中小製造業ではあまりDX化って、ねぇ…という状態が普通ではないかと思います。
まぁ私みたいに趣味でAIいじっているだけでも形にはなるのでどうにか業務効率化につながらないかなぁ…と日々悩んでいるところではあります。
こうやって使えないマクロばかり作らない（作らせない）で業務に直結した何か良いものをこれからは作っていこうと思います。
でも、noteを太らせていくのにこういった”いらないマクロ”も作ったら公開しつつ埋葬していこうとも考えてます。
最後まで読んでくださりありがとうございました。
