フロー作成（オートシェイプ）

Option Explicit

Sub CreateSheets()
Dim ws4 As Worksheet
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Dim ws9 As Worksheet
Dim j As Long
Dim k1 As String
Dim k2 As Long
Dim k3 As String
Dim k4 As String
Dim k5 As String
Dim Addr1 As String
Dim Addr2 As String
Dim WFlow As String
Dim cmax1 As Long
Dim torihiki As String
Dim n As Long: n = 2

Set ws1 = ThisWorkbook.Worksheets("nouhin")
Set ws2 = ThisWorkbook.Worksheets("template")
Set ws9 = ThisWorkbook.Worksheets("z")
cmax1 = ws1.Range("A65536").End(xlUp).Row
torihiki = "OFF"

For j = 2 To cmax1
If torihiki <> ws1.Range("A" & j).Value Then
'If torihiki <> "OFF" Then
' Dim r As Range
' Dim s As Shape
' Dim e As Shape
' Dim c As Shape
' Dim i As Long
' For Each r In ws9.Range("A2", ws9.Cells(ws9.Rows.Count, 1).End(xlUp))
' On Error Resume Next
' Set s = ws4.Shapes(r.Value)
' If Not s Is Nothing Then
' 's.Width = r.Offset(, 1).Value
' Set e = ws4.Shapes(r.Offset(, 2).Value)
' On Error GoTo 0
' If Not e Is Nothing Then
' Set c = ws1.Shapes.AddConnector(msoConnectorElbow, 0, 0, 0, 0)
' c.Line.EndArrowheadStyle = msoArrowheadTriangle
' With c.ConnectorFormat
' .BeginConnect s, 4
' .EndConnect e, 2
' End With
' Set e = Nothing
' End If
' Set s = Nothing
' End If
' Next
'End If
ws2.Copy after:=ThisWorkbook.Worksheets(Worksheets.Count)
Set ws4 = ThisWorkbook.ActiveSheet
ws4.Name = ws1.Range("A" & j).Value
torihiki = ws1.Range("A" & j).Value
End If

If torihiki = ws1.Range("A" & j).Value Then
Addr1 = ws1.Range("f" & j).Value
ws4.Range(Addr1).Value = ws1.Range("g" & j).Value '元⇒テンプレート転記(アドレス1)
Addr2 = ws1.Range("h" & j).Value
ws4.Range(Addr2).Value = ws1.Range("i" & j).Value '元⇒テンプレート転記(アドレス2)
'フロー転記
WFlow = ws1.Range("N" & j).Value
k1 = ws1.Range("M" & j).Value
k3 = ws1.Range("O" & j).Value
k4 = ws1.Range("J" & j).Value
Select Case WFlow
Case "処理"
With ws4.Shapes.AddShape(msoShapeFlowchartProcess, 0, 0, 100, 50)
.Fill.ForeColor.RGB = RGB(255, 255, 255)
.Line.ForeColor.RGB = vbBlack
.TextFrame.VerticalAlignment = xlVAlignCenter
.TextFrame.HorizontalAlignment = xlHAlignCenter
With .TextFrame.Characters
.Text = k3
.Font.Name = "Meiryo UI"
.Font.Size = 10
.Font.Bold = False
.Font.Color = vbBlack
End With
.Top = Range(k1).Top
.Left = Range(k1).Left
.Name = k4
End With
k5 = Range(k1).Offset(3).Address
Case "判断"
With ws4.Shapes.AddShape(msoShapeFlowchartDecision, 0, 0, 100, 50)
.Fill.ForeColor.RGB = RGB(255, 255, 255)
.Line.ForeColor.RGB = vbBlack
.TextFrame.VerticalAlignment = xlVAlignCenter
.TextFrame.HorizontalAlignment = xlHAlignCenter
With .TextFrame.Characters
.Text = k3
.Font.Name = "Meiryo UI"
.Font.Size = 10
.Font.Bold = False
.Font.Color = vbBlack
End With
.Top = Range(k1).Top
.Left = Range(k1).Left
.Name = k4
End With
k5 = Range(k1).Offset(3).Address
Case "区画"
With ws4.Shapes.AddShape(msoShapeFlowchartPredefinedProcess, 0, 0, 100, 50)
.Fill.ForeColor.RGB = RGB(255, 255, 255)
.Line.ForeColor.RGB = vbBlack
.TextFrame.VerticalAlignment = xlVAlignCenter
.TextFrame.HorizontalAlignment = xlHAlignCenter
With .TextFrame.Characters
.Text = k3
.Font.Name = "Meiryo UI"
.Font.Size = 10
.Font.Bold = False
.Font.Color = vbBlack
End With
.Top = Range(k1).Top
.Left = Range(k1).Left
.Name = k4
End With
k5 = Range(k1).Offset(3).Address
Case "書類"
With ws4.Shapes.AddShape(msoShapeFlowchartDocument, 0, 0, 100, 50)
.Fill.ForeColor.RGB = RGB(255, 255, 255)
.Line.ForeColor.RGB = vbBlack
.TextFrame.VerticalAlignment = xlVAlignCenter
.TextFrame.HorizontalAlignment = xlHAlignCenter
With .TextFrame.Characters
.Text = k3
.Font.Name = "Meiryo UI"
.Font.Size = 10
.Font.Bold = False
.Font.Color = vbBlack
End With
.Top = Range(k1).Top
.Left = Range(k1).Left
.Name = k4
End With
k5 = Range(k1).Offset(3).Address
Case "作業"
With ws4.Shapes.AddShape(msoShapeFlowchartConnector, 0, 0, 15, 15)
.Fill.ForeColor.RGB = RGB(255, 255, 255)
.Line.ForeColor.RGB = vbBlack
.TextFrame.VerticalAlignment = xlVAlignCenter
.TextFrame.HorizontalAlignment = xlHAlignCenter
With .TextFrame.Characters
.Text = k3
.Font.Name = "Meiryo UI"
.Font.Size = 10
.Font.Bold = False
.Font.Color = vbBlack
End With
.Top = Range(k1).Top
.Left = Range(k1).Left
.Name = k4
End With
k5 = k1
Case "LTO"
With ws4.Shapes.AddShape(msoShapeFlowchartSequentialAccessStorage, 0, 0, 50, 50)
.Fill.ForeColor.RGB = RGB(255, 255, 255)
.Line.ForeColor.RGB = vbBlack
.TextFrame.VerticalAlignment = xlVAlignCenter
.TextFrame.HorizontalAlignment = xlHAlignCenter
With .TextFrame.Characters
.Text = k3
.Font.Name = "Meiryo UI"
.Font.Size = 10
.Font.Bold = False
.Font.Color = vbBlack
End With
.Top = Range(k1).Top
.Left = Range(k1).Left
.Name = k4
End With
k5 = Range(k1).Offset(3).Address
Case "ディスク"
With ws4.Shapes.AddShape(msoShapeFlowchartMagneticDisk, 0, 0, 100, 50)
.Fill.ForeColor.RGB = RGB(255, 255, 255)
.Line.ForeColor.RGB = vbBlack
.TextFrame.VerticalAlignment = xlVAlignCenter
.TextFrame.HorizontalAlignment = xlHAlignCenter
With .TextFrame.Characters
.Text = k3
.Font.Name = "Meiryo UI"
.Font.Size = 10
.Font.Bold = False
.Font.Color = vbBlack
End With
.Top = Range(k1).Top
.Left = Range(k1).Left
.Name = k4
End With
k5 = Range(k1).Offset(3).Address
Case "画面"
With ws4.Shapes.AddShape(msoShapeFlowchartDisplay, 0, 0, 100, 50)
.Fill.ForeColor.RGB = RGB(255, 255, 255)
.Line.ForeColor.RGB = vbBlack
.TextFrame.VerticalAlignment = xlVAlignCenter
.TextFrame.HorizontalAlignment = xlHAlignCenter
With .TextFrame.Characters
.Text = k3
.Font.Name = "Meiryo UI"
.Font.Size = 10
.Font.Bold = False
.Font.Color = vbBlack
End With
.Top = Range(k1).Top
.Left = Range(k1).Left
.Name = k4
End With
k5 = Range(k1).Offset(3).Address
End Select
'ステップ内容
If k1 <> "" Then
With ws4.Shapes.AddShape(msoShapeFlowchartProcess, 0, 0, 150, 50)
.Fill.Visible = False
.Line.Visible = msoFalse
.TextFrame.VerticalAlignment = xlVAlignTop
.TextFrame.HorizontalAlignment = xlHAlignCenter
With .TextFrame.Characters
.Text = "[" & ws1.Range("P" & j).Value & "]"
.Font.Name = "Meiryo UI"
.Font.Size = 10
.Font.Bold = False
.Font.Color = vbBlack
End With
.Top = Range(k5).Top
.Left = Range(k5).Left
.Name = k4 & "内容"
End With
End If
End If
P_1:
Next

Set ws4 = Nothing
Application.DisplayAlerts = False
Application.DisplayAlerts = True

Dim newfilename As String
newfilename = Format(Date, "yyyy-mm-dd") & "_" & ThisWorkbook.Name
Application.DisplayAlerts = False
ThisWorkbook.SaveAs Filename:=ThisWorkbook.Path & "\" & newfilename
Application.DisplayAlerts = True
End Sub

Sub AddConnector01()
Dim r As Range
Dim s As Shape
Dim e As Shape
Dim c As Shape
Dim i As Long
'プログラム2｜シート設定
Dim ws1 As Worksheet, ws2 As Worksheet
Set ws1 = ThisWorkbook.Worksheets("a")
Set ws2 = ThisWorkbook.Worksheets("z")

'With ActiveSheet
For Each r In ws2.Range("A2", ws2.Cells(ws2.Rows.Count, 1).End(xlUp))
On Error Resume Next
Set s = ws1.Shapes(r.Value)
If Not s Is Nothing Then
s.Width = r.Offset(, 1).Value
Set e = ws1.Shapes(r.Offset(, 2).Value)
On Error GoTo 0
If Not e Is Nothing Then

'*****Connector処理
Set c = ws1.Shapes.AddConnector(msoConnectorElbow, 0, 0, 0, 0)
c.Line.EndArrowheadStyle = msoArrowheadTriangle
With c.ConnectorFormat
.BeginConnect s, 4
.EndConnect e, 2
End With
'（最短経路で再接続）
'c.RerouteConnections
'*****

Set e = Nothing
End If
Set s = Nothing
End If
Next
'End With
End Sub