【無料公開】Excelで方位図を一瞬作図！実務で使えるVBAマクロ（削除機能付き）
■はじめに
Excelで配置図や仮設計画を作っていると、
方位マークを毎回手描き
矢印の角度調整が面倒
修正のたびに作り直し
こういう無駄、ありませんか？
本記事では
「セル選択 → 実行」だけで方位図を自動作図するVBA」
を無料で公開します。
さらに今回は
図形一括削除マクロ付き
■できること
✔ コンパス（N・E・S・W）
✔ 北矢印（シンプル）
✔ 角度指定矢印（真北以外対応）
✔ 十字補助線付き
✔ 三角＋円タイプ（意匠向け）
✔ 選択範囲の図形を一括削除
■マクロの組み込み方法（初心者OK）
① VBAを開く
Alt + F11
② 標準モジュールを追加
挿入 → 標準モジュール
③ 下記コードを丸ごと貼り付け
' ===== ユーザー定義型：方位文字 =====
Type CompassChar
txt As String ' 方位文字
xOffset As Double ' 円中心からのXオフセット
yOffset As Double ' 円中心からのYオフセット
End Type
' ===== メインマクロ =====
Sub ①方位図_コンパス()
Dim ws As Worksheet
Set ws = ActiveSheet
'========================
' ■倍率（ここだけ変更）
'========================
Dim SCAL As Double
SCAL = 0.7 '← 1=標準 / 0.5=半分 / 2=2倍
'========================
' ■セル選択チェック
'========================
If TypeName(Selection) <> "Range" Then
MsgBox "セルを選択してください"
Exit Sub
End If
Dim sel As Range
Set sel = Selection
Dim xPos As Double, yPos As Double
xPos = sel.Left + sel.Width / 2
yPos = sel.Top + sel.Height / 2
'========================
' ■調整パラメータ（倍率反映）
'========================
Dim radius As Double: radius = 30 * SCAL
Dim txtWidth As Double: txtWidth = 15 * SCAL
Dim txtHeight As Double: txtHeight = 15 * SCAL
'========================
' ■方位文字位置（倍率反映）
'========================
Dim compass(1 To 4) As CompassChar
compass(1).txt = "N"
compass(1).xOffset = -5 * SCAL
compass(1).yOffset = (-30 - 12) * SCAL
compass(2).txt = "E"
compass(2).xOffset = (30 + 1) * SCAL
compass(2).yOffset = -5 * SCAL
compass(3).txt = "S"
compass(3).xOffset = -5 * SCAL
compass(3).yOffset = (30) * SCAL
compass(4).txt = "W"
compass(4).xOffset = (-30 - 15) * SCAL
compass(4).yOffset = -5 * SCAL
'========================
' ■作図
'========================
Dim shpList As Collection
Set shpList = New Collection
'円
Dim shpCircle As Shape
Set shpCircle = ws.Shapes.AddShape(msoShapeOval, _
xPos - radius, yPos - radius, radius * 2, radius * 2)
shpCircle.Line.ForeColor.RGB = RGB(0, 0, 0)
shpList.Add shpCircle
'文字
Dim i As Integer
For i = 1 To 4
Call DrawCompassText(ws, shpList, _
compass(i).txt, _
xPos + compass(i).xOffset, _
yPos + compass(i).yOffset, _
txtWidth, txtHeight)
Next i
'========================
' ■グループ化
'========================
Dim arrShapes() As Variant
ReDim arrShapes(1 To shpList.Count)
For i = 1 To shpList.Count
arrShapes(i) = shpList(i).Name
Next i
ws.Shapes.Range(arrShapes).Group
End Sub
' ===== サブルーチン =====
Sub DrawCompassText(ws As Worksheet, shpList As Collection, txt As String, xPos As Double, yPos As Double, w As Double, h As Double)
Dim shpText As Shape
Set shpText = ws.Shapes.AddTextbox(msoTextOrientationHorizontal, xPos, yPos, w, h)
With shpText
.TextFrame.Characters.text = txt
.TextFrame.HorizontalAlignment = xlHAlignCenter
.TextFrame.VerticalAlignment = xlVAlignCenter
.TextFrame.Characters.Font.Bold = True
.Fill.Transparency = 1
.Line.Visible = msoFalse
End With
shpList.Add shpText
End Sub
Sub ②方位図_矢角度入力_色選択()
Dim ws As Worksheet
Set ws = ActiveSheet
' ===== 選択セル中心 =====
If TypeName(Selection) <> "Range" Then
MsgBox "セルを選択してください"
Exit Sub
End If
Dim sel As Range
Set sel = Selection
Dim xPos As Double, yPos As Double
xPos = sel.Left + sel.Width / 2
yPos = sel.Top + sel.Height / 2
' ===== 角度入力 =====
Dim strAngle As String
Dim arrowAngle As Double
strAngle = InputBox("矢印の角度を入力してください（0度＝北、時計回り）", "方位角度", "0")
If strAngle = "" Then Exit Sub
If Not IsNumeric(strAngle) Then
MsgBox "数値を入力してください"
Exit Sub
End If
arrowAngle = CDbl(strAngle)
If arrowAngle < 0 Or arrowAngle >= 360 Then
MsgBox "0～359度の範囲で入力してください"
Exit Sub
End If
' ===== 色選択 =====
Dim colorNo As Variant
Dim lineRGB As Long
colorNo = InputBox("色を選択してください" & vbCrLf & _
"1：黒 2：赤 3：青 4：緑", "色選択", 2)
If colorNo = "" Then Exit Sub
If Not IsNumeric(colorNo) Then
MsgBox "数値を入力してください"
Exit Sub
End If
Select Case CLng(colorNo)
Case 1: lineRGB = RGB(0, 0, 0)
Case 2: lineRGB = RGB(255, 0, 0)
Case 3: lineRGB = RGB(0, 0, 255)
Case 4: lineRGB = RGB(0, 128, 0)
Case Else
MsgBox "1～4を入力してください"
Exit Sub
End Select
' ===== パラメータ =====
Dim arrowLength As Double: arrowLength = 30
Dim tipSize As Double: tipSize = 10
Dim txtWidth As Double: txtWidth = 20
Dim txtHeight As Double: txtHeight = 15
Dim N_offset As Double: N_offset = 12
Dim shpList As Collection
Set shpList = New Collection
' ===== ラジアン変換 =====
Dim theta As Double
theta = arrowAngle * WorksheetFunction.Pi() / 180
' ===== 終点 =====
Dim xEnd As Double, yEnd As Double
xEnd = xPos + arrowLength * Sin(theta)
yEnd = yPos - arrowLength * Cos(theta)
' ===== 矢印線 =====
Dim shpArrow As Shape
Set shpArrow = ws.Shapes.AddLine(xPos, yPos, xEnd, yEnd)
shpArrow.Line.ForeColor.RGB = lineRGB
shpArrow.Line.Weight = 2
shpList.Add shpArrow
' ===== 三角形 =====
Dim shpTip As Shape
Set shpTip = ws.Shapes.AddShape(msoShapeIsoscelesTriangle, xEnd - tipSize / 2, yEnd - tipSize / 2, tipSize, tipSize)
With shpTip
.Fill.ForeColor.RGB = lineRGB
.Line.Visible = msoFalse ' ←これで黒枠消える
.Rotation = arrowAngle
End With
' ===== N文字 =====
Dim xText As Double, yText As Double
xText = xEnd + N_offset * Sin(theta)
yText = yEnd - N_offset * Cos(theta)
Dim shpText As Shape
Set shpText = ws.Shapes.AddTextbox(msoTextOrientationHorizontal, xText - txtWidth / 2, yText - txtHeight / 2, txtWidth, txtHeight)
shpText.TextFrame.Characters.text = "N"
shpText.TextFrame.HorizontalAlignment = xlHAlignCenter
shpText.TextFrame.VerticalAlignment = xlVAlignCenter
shpText.TextFrame.Characters.Font.Bold = True
shpText.TextFrame.Characters.Font.Color = RGB(0, 0, 0) ' 常に黒
shpText.Fill.Transparency = 1
shpText.Line.Visible = msoFalse
shpList.Add shpText
' ===== グループ化 =====
Dim arrShapes() As Variant
ReDim arrShapes(1 To shpList.Count)
Dim i As Integer
For i = 1 To shpList.Count
arrShapes(i) = shpList(i).Name
Next i
ws.Shapes.Range(arrShapes).Group
End Sub
Sub ③方位図_矢印北向き_色選択()
Dim ws As Worksheet
Set ws = ActiveSheet
' ===== 選択セル =====
If TypeName(Selection) <> "Range" Then
MsgBox "セルを選択してください"
Exit Sub
End If
Dim sel As Range
Set sel = Selection
Dim xPos As Double, yPos As Double
xPos = sel.Left + sel.Width / 2
yPos = sel.Top + sel.Height / 2
' ===== 色選択 =====
Dim colorNo As Variant
Dim lineRGB As Long
colorNo = InputBox("色を選択してください" & vbCrLf & _
"1：黒 2：赤 3：青 4：緑", "色選択", 1)
If colorNo = "" Then Exit Sub
If Not IsNumeric(colorNo) Then
MsgBox "数値を入力してください"
Exit Sub
End If
Select Case CLng(colorNo)
Case 1: lineRGB = RGB(0, 0, 0)
Case 2: lineRGB = RGB(255, 0, 0)
Case 3: lineRGB = RGB(0, 0, 255)
Case 4: lineRGB = RGB(0, 128, 0)
Case Else
MsgBox "1～4を入力してください"
Exit Sub
End Select
' ===== パラメータ =====
Dim arrowLength As Double: arrowLength = 30
Dim tipSize As Double: tipSize = 10
Dim txtWidth As Double: txtWidth = 20
Dim txtHeight As Double: txtHeight = 15
Dim N_Xoffset As Double: N_Xoffset = 0
Dim N_Yoffset As Double: N_Yoffset = -arrowLength - 2
Dim shpList As Collection
Set shpList = New Collection
' ===== 矢印線 =====
Dim shpArrow As Shape
Set shpArrow = ws.Shapes.AddLine(xPos, yPos + arrowLength, xPos, yPos)
shpArrow.Line.ForeColor.RGB = lineRGB
shpArrow.Line.Weight = 2
shpList.Add shpArrow
' ===== 三角形 =====
Dim shpTip As Shape
Set shpTip = ws.Shapes.AddShape(msoShapeIsoscelesTriangle, _
xPos - tipSize / 2, yPos - tipSize, tipSize, tipSize)
With shpTip
.Fill.ForeColor.RGB = lineRGB
.Line.Visible = msoFalse ' ←黒枠完全削除
.Rotation = 0
End With
shpList.Add shpTip
' ===== N文字 =====
Dim shpText As Shape
Set shpText = ws.Shapes.AddTextbox(msoTextOrientationHorizontal, xPos + N_Xoffset - txtWidth / 2, yPos + N_Yoffset, txtWidth, txtHeight)
shpText.TextFrame.Characters.text = "N"
shpText.TextFrame.HorizontalAlignment = xlHAlignCenter
shpText.TextFrame.VerticalAlignment = xlVAlignCenter
shpText.TextFrame.Characters.Font.Bold = True
shpText.TextFrame.Characters.Font.Color = RGB(0, 0, 0)
shpText.Fill.Transparency = 1
shpText.Line.Visible = msoFalse
shpList.Add shpText
' ===== グループ化 =====
Dim arrShapes() As Variant
ReDim arrShapes(1 To shpList.Count)
Dim i As Integer
For i = 1 To shpList.Count
arrShapes(i) = shpList(i).Name
Next i
ws.Shapes.Range(arrShapes).Group
End Sub
Sub ④方位図_矢印北向き_十字線_色選択()
Dim ws As Worksheet
Set ws = ActiveSheet
' ===== 選択セル中心 =====
If TypeName(Selection) <> "Range" Then
MsgBox "セルを選択してください"
Exit Sub
End If
Dim sel As Range
Set sel = Selection
Dim xPos As Double, yPos As Double
xPos = sel.Left + sel.Width / 2
yPos = sel.Top + sel.Height / 2
' ===== 色選択 =====
Dim colorNo As Variant
Dim lineRGB As Long
colorNo = InputBox("色を選択してください" & vbCrLf & _
"1：黒 2：赤 3：青 4：緑", "色選択", 3)
If colorNo = "" Then Exit Sub
If Not IsNumeric(colorNo) Then
MsgBox "数値を入力してください"
Exit Sub
End If
Select Case CLng(colorNo)
Case 1: lineRGB = RGB(0, 0, 0)
Case 2: lineRGB = RGB(255, 0, 0)
Case 3: lineRGB = RGB(0, 0, 255)
Case 4: lineRGB = RGB(0, 128, 0)
Case Else
MsgBox "1～4を入力してください"
Exit Sub
End Select
' ===== パラメータ =====
Dim arrowLength As Double: arrowLength = 30
Dim tipSize As Double: tipSize = 10
Dim txtWidth As Double: txtWidth = 20
Dim txtHeight As Double: txtHeight = 15
Dim N_Xoffset As Double: N_Xoffset = 0
Dim N_Yoffset As Double: N_Yoffset = -arrowLength - 2
Dim horLineOffset As Double: horLineOffset = 12
Dim horLineLength As Double: horLineLength = arrowLength
Dim shpList As Collection
Set shpList = New Collection
Dim shpArrow As Shape
Dim shpTip As Shape
Dim shpText As Shape
Dim shpHor As Shape
' ===== 矢印（直線） =====
Set shpArrow = ws.Shapes.AddLine(xPos, yPos + arrowLength, xPos, yPos)
shpArrow.Line.ForeColor.RGB = lineRGB
shpArrow.Line.Weight = 2
shpList.Add shpArrow
' ===== 矢印頭（三角形） =====
Set shpTip = ws.Shapes.AddShape(msoShapeIsoscelesTriangle, _
xPos - tipSize / 2, yPos - tipSize, tipSize, tipSize)
With shpTip
.Fill.ForeColor.RGB = lineRGB
.Line.Visible = msoFalse ' ←これが正解
.Rotation = 0
End With
shpList.Add shpTip
' ===== N文字 =====
Set shpText = ws.Shapes.AddTextbox(msoTextOrientationHorizontal, xPos + N_Xoffset - txtWidth / 2, yPos + N_Yoffset, txtWidth, txtHeight)
shpText.TextFrame.Characters.text = "N"
shpText.TextFrame.HorizontalAlignment = xlHAlignCenter
shpText.TextFrame.VerticalAlignment = xlVAlignCenter
shpText.TextFrame.Characters.Font.Bold = True
shpText.TextFrame.Characters.Font.Color = RGB(0, 0, 0) ' 常に黒
shpText.Fill.Transparency = 1
shpText.Line.Visible = msoFalse
shpList.Add shpText
' ===== 水平線 =====
Set shpHor = ws.Shapes.AddLine(xPos - horLineLength / 2, yPos + horLineOffset, xPos + horLineLength / 2, yPos + horLineOffset)
shpHor.Line.ForeColor.RGB = lineRGB
shpHor.Line.Weight = shpArrow.Line.Weight
shpList.Add shpHor
' ===== グループ化 =====
Dim arrShapes() As Variant
ReDim arrShapes(1 To shpList.Count)
Dim i As Integer
For i = 1 To shpList.Count
arrShapes(i) = shpList(i).Name
Next i
ws.Shapes.Range(arrShapes).Group
End Sub
Sub ⑤方位図_△内接円_N文字_色選択()
Dim ws As Worksheet
Set ws = ActiveSheet
'========================
' ■倍率（ここだけ変更）
'========================
Dim SCAL As Double
SCAL = 0.8 '← 1=標準 / 0.5=半分 / 2=2倍
'========================
' ■基準セル
'========================
If TypeName(Selection) <> "Range" Then
MsgBox "セルを選択してください"
Exit Sub
End If
Dim sel As Range
Set sel = Selection
'========================
' ■色選択
'========================
Dim colorNo As Variant
Dim fillRGB As Long
colorNo = InputBox("色を選択してください" & vbCrLf & _
"1：赤 2：青 3：緑 4：白", "色選択", 1)
If colorNo = "" Then Exit Sub
If Not IsNumeric(colorNo) Then
MsgBox "数値を入力してください"
Exit Sub
End If
Select Case CLng(colorNo)
Case 1: fillRGB = RGB(255, 0, 0)
Case 2: fillRGB = RGB(0, 0, 255)
Case 3: fillRGB = RGB(0, 128, 0)
Case 4: fillRGB = RGB(255, 255, 255)
Case Else
MsgBox "1～4を入力してください"
Exit Sub
End Select
'========================
' ■パラメータ（倍率対応）
'========================
Dim circleRadius As Double: circleRadius = 25 * SCAL
Dim triScale As Double: triScale = 1#
Dim triYOffset As Double: triYOffset = -7 * SCAL
Dim txtWidth As Double: txtWidth = 20 * SCAL
Dim txtHeight As Double: txtHeight = 15 * SCAL
Dim N_Xoffset As Double: N_Xoffset = 0 * SCAL
Dim N_Yoffset As Double: N_Yoffset = -2 * SCAL
'========================
' ■中心
'========================
Dim centerX As Double, centerY As Double
centerX = sel.Left + sel.Width / 2
centerY = sel.Top + sel.Height / 2
'========================
' ■三角形サイズ
'========================
Dim triWidth As Double, triHeight As Double
triWidth = 2 * circleRadius * triScale
triHeight = triWidth * Sqr(3) / 2
Dim triTop As Double, triLeft As Double
triTop = centerY - triHeight / 2 + triYOffset
triLeft = centerX - triWidth / 2
'========================
' ■作図
'========================
Dim shpList As Collection
Set shpList = New Collection
Dim shpCircle As Shape
Dim shpTriangle As Shape
Dim shpText As Shape
'===== 円 =====
Set shpCircle = ws.Shapes.AddShape( _
msoShapeOval, _
centerX - circleRadius, _
centerY - circleRadius, _
circleRadius * 2, _
circleRadius * 2)
With shpCircle
.Line.ForeColor.RGB = RGB(0, 0, 0)
.Line.Weight = 2 * SCAL
.Fill.ForeColor.RGB = fillRGB
.Fill.Transparency = 0
End With
shpList.Add shpCircle
'===== 三角形 =====
Set shpTriangle = ws.Shapes.AddShape( _
msoShapeIsoscelesTriangle, _
triLeft, triTop, triWidth, triHeight)
With shpTriangle
.Fill.ForeColor.RGB = fillRGB
.Line.ForeColor.RGB = RGB(0, 0, 0)
.Line.Weight = 2 * SCAL
.Rotation = 0
End With
shpList.Add shpTriangle
'===== N文字 =====
Set shpText = ws.Shapes.AddTextbox( _
msoTextOrientationHorizontal, _
centerX + N_Xoffset - txtWidth / 2, _
triTop + N_Yoffset - txtHeight, _
txtWidth, txtHeight)
With shpText
.TextFrame.Characters.text = "N"
.TextFrame.HorizontalAlignment = xlHAlignCenter
.TextFrame.VerticalAlignment = xlVAlignCenter
.TextFrame.Characters.Font.Bold = True
.TextFrame.Characters.Font.Color = RGB(0, 0, 0)
.Fill.Transparency = 1
.Line.Visible = msoFalse
End With
shpList.Add shpText
'========================
' ■グループ化
'========================
Dim arrShapes() As Variant
ReDim arrShapes(1 To shpList.Count)
Dim i As Integer
For i = 1 To shpList.Count
arrShapes(i) = shpList(i).Name
Next i
ws.Shapes.Range(arrShapes).Group
MsgBox "方位図 作成完了（倍率対応）"
End Sub
Sub ⑥選択範囲_図形削除()
Dim ws As Worksheet
Set ws = ActiveSheet
Dim rng As Range
Set rng = Selection
If rng Is Nothing Then
MsgBox "セル範囲を選択してください"
Exit Sub
End If
Dim shp As Shape
Dim i As Long
' ★後ろからループ（削除安定）
For i = ws.Shapes.Count To 1 Step -1
Set shp = ws.Shapes(i)
' ===== 図形の位置がセル範囲内か判定 =====
If Not Intersect(rng, shp.TopLeftCell) Is Nothing Then
shp.Delete
End If
Next i
End Sub
■使い方
●方位図を描く
セルを選択
Alt + F8
マクロを選択して実行
●角度指定
0°＝北
90°＝東
時計回り
●図形を削除（重要）
範囲選択
⑥選択範囲_図形削除 実行
範囲内の図形だけ一括削除
■カスタマイズ
SCAL = 0.7
小さく → 0.5
大きく → 1.5
■実務メリット
作図時間：激減
修正：一瞬
Excelでの図面作成に便利
補助ツールとして
■免責事項
本マクロは無償提供です。
動作保証は行いません
使用による損害の責任は負いません
自己責任でご利用ください
再配布は禁止
■今後
今後追加予定
敷地図作成マクロ（無料版）
仮設配置統合マクロ
■まとめ
セル選択だけで方位図作成
修正・削除も一発
実務効率が良い
