Excelで組織図を作成
こんにちは。
派犬事務員のコロ子です。
4月は部署異動の時期ですね。(もう5月になっちゃったけど)
コロ子もこの4月からから新しい部署に異動になった。
今年は異動も多く、新しい部署ができたりかなり大胆な組織変更があった。
そこで上司から「組織図を簡単に作れるようなツールを作って」の依頼がきた。
現行はエクセル方眼紙で作成していて、変更がある度に、コピーしたりセルを結合したり、修正に手間がかかっている。
マクロを作るにあたって、セルに書き込むタイプだと形を整えるのが大変なので、セルの代わりに図形にして、好きな位置に置く事にした。
【完成図】
項目は図形なので、イレギュラーな場合でも自由に移動できる。
例えば、後から「こんな風にしたい」とか言われても対応OK。
下準備
別のシートに社員の一覧表を作成する。
こんな感じで必要な項目を一覧表にしてテーブルにする。
表にカーソルを置いて「Ctr+T」でテーブルに変更できる。
テーブル名は「名簿テーブル」とした。
テーブルは最近のお気に入り。
コード
まずは図形の上位置と高さを決める。これと思う数字を入れて後で調整する。
名簿テーブルの列番号もEnumにする。
'図形の位置上側******************* 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」
オブジェクト名はプロパティウインドウから変更できます。