はじめに
業務改善の現場では、工程フローや業務手順をPowerPointで説明する機会が多くあります。
でも実際は、
- とりあえず文字を並べて
- 枠で囲んで
- 矢印でつないで
- イラストも入れたくなって
- 位置がズレて直して…
気づけば 地味に時間が溶けていく作業 になりがちです。
そこで今回は、VBAマクロで工程フローを一発生成する方法を紹介します。
工程名をテキストで書くだけで、
- 「枠で囲まれ」
- 「矢印でつながれ」
- 「イラストが自動で入り」
- 「スライド幅にきれいに収まる」
という “理想のフロー図” が一瞬で完成 します。
使用技術
- PowerPoint × VBA
- 挿入したい画像
① まずは文字だけ置いてみる（スタートは超シンプル）
最初は、スライド1枚目に工程名をテキストで並べるだけ。
ただの箇条書きですが、ここから一気に化けます。
② 枠と矢印をつけて“フローっぽく”してみた（VBAの出番）
次に、VBAマクロを実行すると…
- 工程ごとに枠がつき
- 横一列に整列し
- 矢印でつながり
- レイアウトも自動調整
という 「手作業でやってたアレ」 が一瞬で終わります。
③ 欲張ってイラストもつけてみた（伝わる資料に進化）
さらに、工程ごとにイラストを自動配置するようにすると、
資料の“伝わりやすさ”が一気に上がります。
画像はデスクトップに置いて、フォルダ名を指定します。
画像サイズも位置も自動調整されるので、
「ちょっと右にズレてる…」という微調整から完全に解放されます。
④ 出力結果（完成イメージ）
- 工程枠は横一列に整列
- 枠の中に工程名＋下にイラスト
- 枠の外にネイビー矢印（中央位置）
- 全体がスライド内に収まるように自動調整
ここで、「Sub/ユーザー フォームの実行」
PPTのシート2枚目にフロー＋イラストが入ってきました！ 見やすいフロー図になりました。
おわりに
「文字だけの工程リスト」が、
VBAひとつで“伝わるフロー図”に化ける のは本当に便利です。
業務改善の資料作成が爆速になるので、
ぜひあなたの現場でも使ってみてください。
フルVBAコード（整形済み）
Option Explicit
'===========================================================
' PowerPoint工程フロー自動生成マクロ（6工程版）
'===========================================================
Sub CreateFlow6StepsLeftAlignedWithLongArrows()
Const msoShapeRoundedRectangle = 5
Const msoTrue = -1
Const ppVerticalAnchorMiddle = 3
Const ppAutoSizeNone = 0
Const ppAlignCenter = 2
Const msoArrowheadTriangle = 3
Dim sld As Slide
Dim shp As Shape
Dim lines() As String
Dim rawText As String
Dim i As Long
Dim xPos As Single: xPos = 20
Dim yPos As Single: yPos = 150
Dim xPitch As Single: xPitch = 160
Dim stepShape As Shape
Dim iconShape As Shape
Dim iconPath As String
Dim iconMap As Object
Dim shapeList As Collection
Dim groupShape As Shape
Dim frameShape As Shape
Set iconMap = CreateObject("Scripting.Dictionary")
iconMap.Add "在庫確認", "souko_building.png"
iconMap.Add "契約残確認", "shigoto_woman_casual.png"
iconMap.Add "発注", "computer_tablet_man.png"
iconMap.Add "受注確認", "computer_income_businessman.png"
iconMap.Add "配送", "takuhai_truck_man_nimotsu.png"
iconMap.Add "店着", "building_shop2_yellow.png"
Dim basePath As String
basePath = "C:\Users\kasug\OneDrive\デスクトップ\PPT画像\"
For Each shp In ActivePresentation.Slides(1).Shapes
If shp.Type = msoTextBox Then
If Trim(shp.TextFrame.TextRange.Text) <> "" Then
rawText = Replace(shp.TextFrame.TextRange.Text, vbCrLf, vbLf)
lines = Split(rawText, vbLf)
Exit For
End If
End If
Next shp
If Not IsArray(lines) Then
MsgBox "工程テキストが見つかりませんでした。"
Exit Sub
End If
If ActivePresentation.Slides.Count < 2 Then
ActivePresentation.Slides.Add 2, ppLayoutBlank
End If
Set sld = ActivePresentation.Slides(2)
For i = 0 To UBound(lines)
Dim stepText As String
stepText = Trim(lines(i))
Set shapeList = New Collection
Set stepShape = sld.Shapes.AddShape(msoShapeRoundedRectangle, xPos, yPos, 120, 50)
stepShape.Fill.ForeColor.RGB = RGB(173, 216, 230)
stepShape.Line.ForeColor.RGB = RGB(255, 255, 255)
With stepShape.TextFrame
.VerticalAnchor = ppVerticalAnchorMiddle
.AutoSize = ppAutoSizeNone
.WordWrap = msoTrue
With .TextRange
.Text = stepText
.Font.Name = "Meiryo UI"
.Font.Size = 15
.Font.Bold = msoTrue
.ParagraphFormat.Alignment = ppAlignCenter
End With
End With
shapeList.Add stepShape
If iconMap.Exists(stepText) Then
iconPath = basePath & iconMap(stepText)
If Dir(iconPath) <> "" Then
Set iconShape = sld.Shapes.AddPicture(iconPath, msoFalse, msoTrue, xPos + 15, yPos + 45, 90, 90)
shapeList.Add iconShape
End If
End If
Dim shapeNames() As String
ReDim shapeNames(1 To shapeList.Count)
Dim j As Long
For j = 1 To shapeList.Count
shapeNames(j) = shapeList(j).Name
Next
Set groupShape = sld.Shapes.Range(shapeNames).Group
Dim frameLeft As Single, frameTop As Single
Dim frameWidth As Single, frameHeight As Single
frameLeft = groupShape.Left - 5
frameTop = groupShape.Top - 5
frameWidth = groupShape.Width + 10
frameHeight = groupShape.Height + 10
Set frameShape = sld.Shapes.AddShape(msoShapeRoundedRectangle, frameLeft, frameTop, frameWidth, frameHeight)
frameShape.Fill.Visible = msoFalse
frameShape.Line.ForeColor.RGB = RGB(100, 100, 100)
frameShape.Line.Weight = 1.5
Set groupShape = sld.Shapes.Range(Array(groupShape.Name, frameShape.Name)).Group
If i < UBound(lines) Then
Dim arrowShape As Shape
Set arrowShape = sld.Shapes.AddLine(xPos + 130, yPos + 60, xPos + 150, yPos + 60)
With arrowShape.Line
.ForeColor.RGB = RGB(0, 0, 128)
.Weight = 2.5
.EndArrowheadStyle = msoArrowheadTriangle
End With
End If
xPos = xPos + xPitch
Next i
End Sub
---