こんにちは。
派犬事務員のコロ子です。
4月は部署異動の時期ですね。（もう5月になっちゃったけど）
コロ子もこの4月からから新しい部署に異動になった。
今年は異動も多く、新しい部署ができたりかなり大胆な組織変更があった。
そこで上司から「組織図を簡単に作れるようなツールを作って」の依頼がきた。
現行はエクセル方眼紙で作成していて、変更がある度に、コピーしたりセルを結合したり、修正に手間がかかっている。
マクロを作るにあたって、セルに書き込むタイプだと形を整えるのが大変なので、セルの代わりに図形にして、好きな位置に置く事にした。
【完成図】
項目は図形なので、イレギュラーな場合でも自由に移動できる。
例えば、後から「こんな風にしたい」とか言われても対応OK。
下準備
別のシートに社員の一覧表を作成する。
こんな感じで必要な項目を一覧表にしてテーブルにする。
表にカーソルを置いて「Ctr＋T」でテーブルに変更できる。
テーブル名は「名簿テーブル」とした。
テーブルは最近のお気に入り。
コード
まずは図形の上位置と高さを決める。これと思う数字を入れて後で調整する。
名簿テーブルの列番号もEnuｍにする。
'図形の位置上側*******************
Const POSITION1 As Long = 70 '事業部長
Const POSITION2 As Long = 180 '部長
Const POSITION3 As Long = 300 '課長
Const POSITION4 As Long = 360 '課員
'図形の高さ***********************
Const HEIGHT1 As Long = 60 '管理職用
Const HEIGHT2 As Long = 20 '一般職用
'名簿テーブルの列
Enum colname
c_Id = 1
c_Name
c_Gender
c_Employ
c_Position
c_bu
c_Ka
c_Count
End Enum
名簿テーブルより図形を作成する。
ちょっとややこしいけどポイントは
Dictionaryオブジェクトで部＋課をキーにして部署ごとに要素を作成する。
アイテムを配列（Collectionオブジェクト）にして部署のメンバーの情報（名簿テーブルの行）を入れる。
【クラスモジュール：PersonData】
Private person As Collection
Sub init(lst As ListRow)
Set person = New Collection
person.Add lst
End Sub
Sub Add_dic(lst As ListRow)
person.Add lst
End Sub
Public Property Get GetPersonData() As Collection
Set GetPersonData = person
End Property
【標準モジュール】
名簿テーブル：Sheet1
組織図：Sheet3
に作成。
'Dictionaryオブジェクトの参照設定(Microsoft Scripting Runtime)忘れずに！
Sub Organizational_Chart()
Application.ScreenUpdating = True
Dim teamDic As Dictionary
Set teamDic = New Dictionary
Dim lst As ListObject
Set lst = Sheet1.ListObjects("名簿テーブル")
Dim ran As ListRow
Dim Kanrisyoku() As ListRow '事業部長と部長
Dim i As Long
For Each ran In lst.ListRows
If ran.Range(c_Ka) <> "" Then
'部と課の組み合わせをキーとする
Dim dickey As String
dickey = ran.Range(c_bu) & ran.Range(c_Ka)
If teamDic.Exists(dickey) Then
Call teamDic.Item(dickey).Add_dic(ran)
Else
teamDic.Add dickey, New PersonData
Call teamDic.Item(dickey).init(ran)
End If
Else
ReDim Preserve Kanrisyoku(i)
Set Kanrisyoku(i) = ran
i = i + 1
End If
Next ran
'人ごとに図形を作成する
Dim place As Long
Dim buf As Variant
For Each buf In teamDic.Keys
Call MakeShape(teamDic.Item(buf).GetPersonData, place)
place = place + 1
Next buf
'事業部長、部長を作成
Call SapeKanrisyoku(teamDic, Kanrisyoku)
Application.ScreenUpdating = True
End Sub
図形の位置とテキストを作成する
Sub MakeShape(coll As Collection, place As Long)
Dim left As Long
Dim top As Long
Dim c As Long
c = POSITION4 '一般職員用トップの位置
Dim i As Long
For i = 1 To coll.Count
With coll(i)
'左位置の調整
left = 50 + (100 + 50) * place
Dim height As Long
height = HEIGHT2
'上位置の調整
top = GetTop(c, .Range(c_Position), height)
'表示名
Dim nameText As String
nameText = MakeTaxtName(.Range(c_Name), .Range(c_Ka), .Range(c_Position), .Range(c_Employ))
End With
Call ShapeAdd(nameText, coll(i).Range(c_Employ), left, top, height)
Next i
End Sub'表示名を作成
Function MakeTaxtName(name As String, Section As String, Position As String, emp As String) As String
If Position <> "" Then
MakeTaxtName = Section & vbCrLf & name & vbCrLf & Position & " (" & emp & ")"
Else
MakeTaxtName = name & " (" & emp & ")"
End If
End Function'図形の上位置をセットする
Function GetTop(ByRef c As Long, Position As String, ByRef height As Long) As Long
If Position = "課長" Then
GetTop = POSITION3
height = HEIGHT1
Else '一般職員
GetTop = c
c = c + 20
height = 20
End If
End Function図形を作成（プロパティをセットする）
Sub ShapeAdd(nameText As String, Employ As String, left As Long, top As Long, height As Long)
Dim R As Long
Dim G As Long
Dim B As Long
With Sheet3.Shapes.AddShape _
(msoShapeRectangle, left, top, 100, height) '図形のタイプ、左位置、上の位置、幅、高さ
'表示文字の指定
.TextFrame.Characters.Text = nameText
.TextFrame.Characters.Font.Size = 10.5
'図形内テキストのフォントカラーを指定する
.TextFrame.Characters.Font.Color = RGB(0, 0, 0)
'図形内のテキスト水平方向を中央位置にする
.TextFrame.HorizontalAlignment = xlHAlignCenter
'図形内のテキスト縦方向を中央位置にする
.TextFrame.VerticalAlignment = xlVAlignCenter
Call MakeRGB(Employ, R, G, B)
'図形の枠線の色を指定する
.Line.ForeColor.RGB = RGB(0, 0, 0)
.Line.Weight = 1
'図形の塗りつぶし色を指定する
.Fill.ForeColor.RGB = RGB(R, G, B)
'セルに合わせて移動するがサイズ変更はしない
.Placement = xlMove
End With
End Sub'雇用区分ごとに図形の色をセットする
Sub MakeRGB(ByVal Employ As String, R As Long, ByRef G As Long, ByRef B As Long)
Select Case Employ
Case "A"
R = 204
G = 255
B = 255
Case "B"
R = 255
G = 255
B = 153
Case "C"
R = 153
G = 204
B = 255
Case "犬"
R = 146
G = 208
B = 80
End Select
End Sub
管理職（事業部長、部長）用の図形を作成する
位置合わせは力ずく。（上手くできなければ後で移動してもOK)
Sub SapeKanrisyoku(teamDic As Dictionary, Kanrisyoku() As ListRow)
Dim left1 As Long
Dim left2 As Long
Dim top As Long
Dim height As Long
Dim nameText As String
Dim ran As Variant
For Each ran In Kanrisyoku()
nameText = MakeTaxtName(ran.Range(c_Name), ran.Range(c_bu), ran.Range(c_Position), ran.Range(c_Employ))
height = HEIGHT1
If ran.Range(c_Position) = "事業部長" Then
top = POSITION1
left1 = (50 + (100 + 50) * teamDic.Count + 100) / 2 - 50 - 50
Call ShapeAdd(nameText, ran.Range(c_Employ), left1, top, height)
ElseIf ran.Range(c_Position) = "部長" Then
top = POSITION2
Dim buf As Variant
Dim cnt As Long
For Each buf In teamDic.Keys
If InStr(buf, ran.Range(c_bu)) <> 0 Then
cnt = cnt + 1
End If
Next buf
left2 = left2 + 50 + ((100 + 50) * cnt - 50) / 2 - 50
Call ShapeAdd(nameText, ran.Range(c_Employ), left2, top, height)
left2 = (100 + 50) * cnt
cnt = 0
End If
Next ran
End Sub
【図形の初期化】
図形を作成した後に引いた線はそのままにしたいので、Rectangle（図形）とPicture（後で作成する集計の表）のみを削除
Sub DelShape()
Application.ScreenUpdating = False
Dim shp As Shape
For Each shp In Sheet3.Shapes
If InStr(shp.name, "Rectangle") <> 0 Or InStr(shp.name, "Picture") <> 0 Then
shp.Delete
End If
Next shp
Application.ScreenUpdating = True
End Sub
図形の作成は出来たので、ボタンを作成して下記コードを登録すれば完成！
Sub Main()
Call DelShape
Call Organizational_Chart
End Sub
線はマクロで作るの大変なので手作業でお願いします！
追加
クラスモジュールの挿入の仕方
「クラスモジュール：PersonData」はクラスモジュールのコードを書いてください。
新規のクラスモジュールを追加します。
挿入→クラスモジュール
クラスモジュールのオブジェクト名を変更します。
「Class1」→「PersonData」
オブジェクト名はプロパティウインドウから変更できます。
