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

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

ダウンロード
シートの使い方
まとめ

ダウンロード

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

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に保存して...

'[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

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