PR

フローチャートを作るためのマクロ

2019.08.21

フローチャートを作るためのマクロを組んだので紹介する

スポンサーリンク

ダウンロード

この記事で紹介するマクロはこれ

アイコン

flowchart.xlsm

1 ファイル 25.39 KB
ダウンロード

ソースコード全文はこれ

「マクロの記録」の機能を最大限活用して書いた

Sub 開始終了()
    
    Dim Rng  As Range
    Set Rng = ActiveCell
    
    ActiveSheet.Shapes.AddShape(msoShapeRoundedRectangle, Rng.Left, Rng.Top, Rng.Left + 1, Rng.Top + 1).Select
    Selection.Height = Rng.Height
    Selection.Width = Rng.Width * 5
    Selection.ShapeRange.ShapeStyle = msoShapeStylePreset1
    Selection.ShapeRange.TextFrame2.VerticalAnchor = msoAnchorMiddle
    Selection.ShapeRange.TextFrame2.TextRange.ParagraphFormat.Alignment = msoAlignCenter
    Selection.ShapeRange.Adjustments.Item(1) = 0.35

End Sub
Sub 処理()

    Dim Rng  As Range
    Set Rng = ActiveCell
    
    ActiveSheet.Shapes.AddShape(msoShapeRectangle, Rng.Left, Rng.Top, Rng.Left + 1, Rng.Top + 1).Select
    Selection.Height = Rng.Height
    Selection.Width = Rng.Width * 5
    Selection.ShapeRange.ShapeStyle = msoShapeStylePreset1
    Selection.ShapeRange.TextFrame2.TextRange.ParagraphFormat.Alignment = msoAlignCenter
    Selection.ShapeRange.TextFrame2.VerticalAnchor = msoAnchorMiddle

End Sub
Sub 条件分岐()
    
    Dim Rng  As Range
    Set Rng = ActiveCell
    
    ActiveSheet.Shapes.AddShape(msoShapeFlowchartDecision, Rng.Left, Rng.Top, Rng.Left + 1, Rng.Top + 1).Select
    Selection.Height = Rng.Height * 3
    Selection.Width = Rng.Width * 9
    Selection.ShapeRange.ShapeStyle = msoShapeStylePreset1
    Selection.ShapeRange.TextFrame2.VerticalAnchor = msoAnchorMiddle
    Selection.ShapeRange.TextFrame2.TextRange.ParagraphFormat.Alignment = msoAlignCenter

End Sub
Sub データ入出力()
    
    Dim Rng  As Range
    Set Rng = ActiveCell
    
    ActiveSheet.Shapes.AddShape(msoShapeFlowchartData, Rng.Left, Rng.Top, Rng.Left + 1, Rng.Top + 1).Select
    Selection.Height = Rng.Height * 2
    Selection.Width = Rng.Width * 5
    Selection.ShapeRange.ShapeStyle = msoShapeStylePreset1
    Selection.ShapeRange.TextFrame2.VerticalAnchor = msoAnchorMiddle
    Selection.ShapeRange.TextFrame2.TextRange.ParagraphFormat.Alignment = msoAlignCenter
    
End Sub
Sub 手操作入力()
    
    Dim Rng  As Range
    Set Rng = ActiveCell
    
    ActiveSheet.Shapes.AddShape(msoShapeFlowchartManualInput, Rng.Left, Rng.Top, Rng.Left + 1, Rng.Top + 1).Select
    Selection.Height = Rng.Height * 2
    Selection.Width = Rng.Width * 5
    Selection.ShapeRange.ShapeStyle = msoShapeStylePreset1
    Selection.ShapeRange.TextFrame2.VerticalAnchor = msoAnchorMiddle
    Selection.ShapeRange.TextFrame2.TextRange.ParagraphFormat.Alignment = msoAlignCenter

End Sub
Sub ループ開始()

    Dim Rng  As Range
    Set Rng = ActiveCell
    
    ActiveSheet.Shapes.AddShape(msoShapeSnip2SameRectangle, Rng.Left, Rng.Top, Rng.Left + 1, Rng.Top + 1).Select
    Selection.Height = Rng.Height * 2
    Selection.Width = Rng.Width * 5
    Selection.ShapeRange.Adjustments.Item(1) = 0.5
    Selection.ShapeRange.ShapeStyle = msoShapeStylePreset1
    Selection.ShapeRange.TextFrame2.VerticalAnchor = msoAnchorMiddle
    Selection.ShapeRange.TextFrame2.TextRange.ParagraphFormat.Alignment = msoAlignCenter
    
End Sub
Sub ループ終了()

    Dim Rng  As Range
    Set Rng = ActiveCell
    
    ActiveSheet.Shapes.AddShape(msoShapeSnip2SameRectangle, Rng.Left, Rng.Top, Rng.Left + 1, Rng.Top + 1).Select
    Selection.Height = Rng.Height * 2
    Selection.Width = Rng.Width * 5
    Selection.ShapeRange.Adjustments.Item(1) = 0
    Selection.ShapeRange.Adjustments.Item(2) = 0.5
    Selection.ShapeRange.ShapeStyle = msoShapeStylePreset1
    Selection.ShapeRange.TextFrame2.VerticalAnchor = msoAnchorMiddle
    Selection.ShapeRange.TextFrame2.TextRange.ParagraphFormat.Alignment = msoAlignCenter
    
End Sub
Sub 矢印()
    
    Dim Rng  As Range
    Set Rng = ActiveCell
    
    ActiveSheet.Shapes.AddConnector(msoConnectorStraight, Rng.Left, Rng.Top, Rng.Left + 1, Rng.Top + 1).Select
    Selection.Height = 0
    Selection.Width = Rng.Width * 5
    Selection.ShapeRange.Line.EndArrowheadStyle = msoArrowheadTriangle
    With Selection.ShapeRange.Line
        .Visible = msoTrue
        .ForeColor.RGB = RGB(128, 128, 128)
        .Transparency = 0
    End With
    With Selection.ShapeRange.Line
        .Visible = msoTrue
        .Weight = 2
    End With

End Sub
Sub カギ線矢印()
    
    Dim Rng  As Range
    Set Rng = ActiveCell
    
    ActiveSheet.Shapes.AddConnector(msoConnectorElbow, Rng.Left, Rng.Top, Rng.Left + 1, Rng.Top + 1).Select
    Selection.Height = Rng.Height * 2
    Selection.Width = Rng.Width * 5
    Selection.ShapeRange.Line.EndArrowheadStyle = msoArrowheadTriangle
    With Selection.ShapeRange.Line
        .Visible = msoTrue
        .ForeColor.RGB = RGB(128, 128, 128)
        .Transparency = 0
    End With
    With Selection.ShapeRange.Line
        .Visible = msoTrue
        .Weight = 2
    End With

End Sub
Sub テキスト()

    Dim Rng  As Range
    Set Rng = ActiveCell
    
    ActiveSheet.Shapes.AddShape(msoShapeRectangle, Rng.Left, Rng.Top, Rng.Left + 1, Rng.Top + 1).Select
    Selection.Height = Rng.Height * 2
    Selection.Width = Rng.Width * 5
    Selection.ShapeRange.ShapeStyle = msoShapeStylePreset1
    Selection.ShapeRange.Fill.Visible = msoFalse
    Selection.ShapeRange.Line.Visible = msoFalse
    Selection.ShapeRange.TextFrame2.VerticalAnchor = msoAnchorMiddle
    Selection.ShapeRange.TextFrame2.TextRange.ParagraphFormat.Alignment = msoAlignCenter
    
End Sub
Sub 枠()

    Dim Rng  As Range
    Set Rng = ActiveCell
    
    ActiveSheet.Shapes.AddShape(msoShapeRectangle, Rng.Left, Rng.Top, Rng.Left + 1, Rng.Top + 1).Select
    Selection.Height = Rng.Height * 18
    Selection.Width = Rng.Width * 24
    Selection.ShapeRange.ShapeStyle = msoShapeStylePreset1
    Selection.ShapeRange.TextFrame2.TextRange.ParagraphFormat.Alignment = msoAlignCenter
    Selection.ShapeRange.IncrementLeft 1
    Selection.ShapeRange.IncrementTop 18
    Selection.ShapeRange.ScaleWidth 1.0038610039, msoFalse, msoScaleFromTopLeft
    Selection.ShapeRange.ScaleHeight 1.0155148096, msoFalse, msoScaleFromTopLeft
    
End Sub
Sub 点線()

    Dim Rng  As Range
    Set Rng = ActiveCell
    
    ActiveSheet.Shapes.AddShape(msoShapeRectangle, Rng.Left, Rng.Top, Rng.Left + 1, Rng.Top + 1).Select
    Selection.Height = Rng.Height * 2
    Selection.Width = Rng.Width * 5
    Selection.ShapeRange.Fill.Visible = msoFalse
    With Selection.ShapeRange.Line
        .Visible = msoTrue
        .ForeColor.RGB = RGB(0, 0, 0)
        .Transparency = 0
    End With
    With Selection.ShapeRange.Line
        .Visible = msoTrue
        .Weight = 3
    End With
    With Selection.ShapeRange.Line
        .Visible = msoTrue
        .DashStyle = msoLineDash
    End With

End Sub
Sub 保存()

    ActiveWorkbook.Save 'まず上書き保存
    Application.ScreenUpdating = False '画面更新の非表示
    Application.DisplayAlerts = False '警告文の非表示

    'マクロボタンをSheet2に避難させる
    ActiveSheet.Shapes.Range(Array("開始・終了", "処理ボタン", "条件分岐ボタン", "データ出入力ボタン", "手操作入力ボタン", "矢印ボタン", "カギ矢印ボタン", "テキストボタン", "枠ボタン", "保存ボタン", "新規作成ボタン", "ループ開始ボタン", "ループ終了ボタン", "点線ボタン")).Select
    Selection.Cut
    Sheets.Add After:=ActiveSheet
    ActiveSheet.Name = "sheet2"
    ActiveSheet.Paste
    Sheets("Sheet1").Select
    
    ActiveSheet.Shapes.SelectAll '全選択
    Selection.ShapeRange.Group.Select '選択した図形をグループ化
    Selection.Copy '図形をコピー
    
    Dim ppApp As New PowerPoint.Application
    ppApp.Visible = True
    
    Dim ppPrs As PowerPoint.Presentation 'プレゼンテーションオブジェクト
    Set ppPrs = ppApp.Presentations.Open(ThisWorkbook.Path & "\flowchart.pptx") 'プレゼンテーションを開く
    
    ppPrs.Slides(1).Shapes.Paste '図形をパワポにペースト
    ppPrs.Slides(1).Shapes(1).Export PathName:=OneDriveUrlToLocalPath(ThisWorkbook.Path) & "\flowchart.png", Filter:=ppShapeFormatPNG  '図形を画像として保存
    
    ThisWorkbook.Activate
    Sheets("Sheet2").Select
    ActiveSheet.Shapes.Range(Array("開始・終了", "処理ボタン", "条件分岐ボタン", "データ出入力ボタン", "手操作入力ボタン", "矢印ボタン", "カギ矢印ボタン", "テキストボタン", "枠ボタン", "保存ボタン", "新規作成ボタン", "ループ開始ボタン", "ループ終了ボタン", "点線ボタン")).Select
    Selection.Cut
    Sheets("Sheet1").Select
    Range("B2").Select
    ActiveSheet.Paste
    Sheets("Sheet2").Select
    ActiveWindow.SelectedSheets.Delete
    
    ppApp.Quit
    Set ppApp = Nothing
    
    ActiveSheet.Shapes.SelectAll '全選択
    Selection.ShapeRange.Ungroup.Select 'すべてのグループ化を解除
    Range("A1").Select

End Sub
Sub 新規作成()

    ActiveWorkbook.Save 'まず上書き保存
    Application.ScreenUpdating = False '画面更新の非表示
    Application.DisplayAlerts = False '警告文の非表示

    'マクロボタンをSheet2に避難させる
    ActiveSheet.Shapes.Range(Array("開始・終了", "処理ボタン", "条件分岐ボタン", "データ出入力ボタン", "手操作入力ボタン", "矢印ボタン", "カギ矢印ボタン", "テキストボタン", "枠ボタン", "保存ボタン", "新規作成ボタン", "ループ開始ボタン", "ループ終了ボタン", "点線ボタン")).Select
    Selection.Cut
    Sheets.Add After:=ActiveSheet
    ActiveSheet.Name = "sheet2"
    ActiveSheet.Paste
    Sheets("Sheet1").Select
    
    ActiveSheet.Shapes.SelectAll '全選択
    Selection.Delete '図形を削除
    
    'マクロボタンをSheet2から戻す
    Sheets("Sheet2").Select
    ActiveSheet.Shapes.Range(Array("開始・終了", "処理ボタン", "条件分岐ボタン", "データ出入力ボタン", "手操作入力ボタン", "矢印ボタン", "カギ矢印ボタン", "テキストボタン", "枠ボタン", "保存ボタン", "新規作成ボタン", "ループ開始ボタン", "ループ終了ボタン", "点線ボタン")).Select
    Selection.Cut
    Sheets("Sheet1").Select
    Range("B2").Select
    ActiveSheet.Paste
    Sheets("Sheet2").Select
    ActiveWindow.SelectedSheets.Delete
    
    Range("A1").Select

End Sub

↓OneDriveと同期しているフォルダでも使えるようにするためのネットで拾ったコード

[VBA]OneDriveで同期しているファイルまたはフォルダのURLをローカルパスに変換する関数 | 黒い箱の中
概要 Excel VBAのThisWorkbook.FullNameやThisWorkbook.Pathなどで絶対パスを取得する際、ExcelファイルがOneDriveに保存して...
kuroihako.com
 
'[VBA]OneDriveで同期しているファイルまたはフォルダのURLをローカルパスに変換する関数
'Copyright (c) 2020 黒い箱の中 All Rights Reserved.
'This software is released under the GPLv3<https://opensource.org/licenses/GPL-3.0>.
'このソフトウェアはGNU GPLv3の下でリリースされています<https://opensource.org/licenses/GPL-3.0>。;
'* @fn Public Function OneDriveUrlToLocalPath(ByRef Url As String) As String
'* @brief OneDriveのファイルURL又はフォルダURLをローカルパスに変換します。
'* @param[in] Url OneDrive内に保存されたのファイル又はフォルダのURL
'* @return Variant ローカルパスを返します。引数Urlにローカルパスに"https://"以外から始まる文字列を指定した場合、引数Urlを返します。
'* @details OneDriveのファイルURL又はフォルダURLをローカルパスに変換します。本関数は、ExcelブックがOneDrive内に格納されている場合に、Workbook.Path又はWorkbook.FullNameがURLを返す問題を解決するためのものです。
'* https://kuroihako.com/vba/onedriveurltolocalpath/
Public Function OneDriveUrlToLocalPath(ByRef Url As String) As String
Const OneDriveCommercialUrlPattern As String = "*my.sharepoint.com*" '法人向けOneDriveのURLか否かを判定するためのLike右辺値

    '引数がURLでない場合、引数はローカルパスと判断してそのまま返す。
    If Not (Url Like "https://*") Then
        OneDriveUrlToLocalPath = Url
        Exit Function
    End If
    
    'OneDriveのパスを取得しておく(パフォーマンス優先)。
    Static PathSeparator As String
    Static OneDriveCommercialPath As String
    Static OneDriveConsumerPath As String
    
    If (PathSeparator = "") Then
        PathSeparator = Application.PathSeparator
        
        '法人向けOneDrive(OneDrive for Business)のパス
        OneDriveCommercialPath = Environ("OneDriveCommercial")
        If (OneDriveCommercialPath = "") Then OneDriveCommercialPath = Environ("OneDrive")
        
        '個人向けOneDriveのパス
        OneDriveConsumerPath = Environ("OneDriveConsumer")
        If (OneDriveConsumerPath = "") Then OneDriveConsumerPath = Environ("OneDrive")

    End If
    
    '法人向けOneDrive：URL＝"https://会社名-my.sharepoint.com/personal/ユーザー名_domain_com/Documentsファイルパス")
    Dim FilePathPos As Long
    If (Url Like OneDriveCommercialUrlPattern) Then
        FilePathPos = InStr(1, Url, "/Documents") + 10 '10 = Len("/Documents")
        OneDriveUrlToLocalPath = OneDriveCommercialPath & Replace(Mid(Url, FilePathPos), "/", PathSeparator)
        
    '個人向けOneDrive：URL＝"https://d.docs.live.net/CID番号/ファイルパス"
    Else
        FilePathPos = InStr(9, Url, "/") '9 == Len("https://") + 1
        FilePathPos = InStr(FilePathPos + 1, Url, "/")

        If (FilePathPos = 0) Then
            OneDriveUrlToLocalPath = OneDriveConsumerPath
        Else
            OneDriveUrlToLocalPath = OneDriveConsumerPath & Replace(Mid(Url, FilePathPos), "/", PathSeparator)
        End If
    End If

End Function

具体的に使い方を説明する

シートの使い方

エクセルファイルを開くと，この画面が表示される

まず，左側にある「枠」というマクロボタンをクリックして，枠を挿入する

そのまま，「図形の形式→配置→枠線に合わせる」を選択する

あとは左側にあるマクロボタンをクリックして，好きなようにフローチャートを作っていく

矢印でつなぐときには，下の画像のように矢印の両端が緑色の点になるようにしておくと，図形を動かしたときに矢印が勝手についてきてくれるようになる

フローチャートが完成したら，このエクセルシートが保存されているのと同じフォルダに”flowchart.pptx”というパワポのファイルを作っておく（一度作れば，それ以降作り直す必要はない）

このファイルは何も書かれていないまっさらなパワポでいい

作り終えたらパワポを閉じて，エクセルシートの「保存」のマクロボタンを押す

するとあら不思議，エクセルシートが保存してあるのと同じフォルダに，作成したフローチャートが*.png形式で保存されている

まとめ

自分で作っておきながら，あまりの便利さに感心しているので，みんなもぜひ使ってみてほしい

↓おすすめ記事

【Github】WindowsでSourceTreeを使ってExcelファイルのバージョン管理をする
GithubとSourceTreeを使ってExcelファイルのバージョンを管理する方法について説明する．
mtkbirdman.com
2022.06.19
1日のスケジュールをリアルタイムで記録して円グラフにするマクロ
1日のスケジュールをリアルタイムで記録して円グラフにするマクロを組んだので紹介する
mtkbirdman.com
2020.07.03
ノートPCにコーヒーをこぼして水没させた話
ノートPCにコーヒーをこぼして，対処して，PC修理専門店に持ち込んで修理してもらって受け取るまでの話
mtkbirdman.com
2021.11.20
【Excel VBA】円グラフや棒グラフを色相環（HLS色空間）でカラフルに塗り分けるマクロ
Excelの円グラフや棒グラフを色相環（HLS色空間）を使ってカラフルに塗り分けるExcelマクロを紹介する
mtkbirdman.com
2022.08.13
参考にしたサイト

製作にあたって，下のサイトを参考にした

≫フローチャート（フロー図）を作成できるエクセルフリーテンプレート｜マクロVBAを活用
≫エクセルVBAでPowerPointのプレゼンテーションを開く方法・スライドを取得する方法
≫VBAで図として保存する
≫[VBA]OneDriveで同期しているファイルまたはフォルダのURLをローカルパスに変換する関数

Excel VBA
質問・感想・意見などあれば気軽にTwitterのDMかコメントお願いします！
スポンサーリンク
@mtk_birdman
スポンサーリンク

コメント