VBA シート指定攻防戦

こんにちは。
派犬事務員のコロ子です。

シートの指定方法

シートの指定方法って悩む。

①シート名で指定
　Worksheets("シート名").Range("A1").Value

②位置で指定
　Worksheets(1).Range("A1").Value

③オブジェクト指定
　Sheet1.Range("A1").Value

簡単だからなんとなくいつもオブジェクト指定にしてるけど、シートをコピーして、元のシートを削除されると困る。直すのにはVBEエディタを開かなくちゃいけないから、ユーザーの自力修正はハードルが高い。
やっぱりシート名指定が安全なのか、と思っていたけど・・・。

Aさん：「ちょっと！！！マクロが動かないんだけど！！！」

コロ子：「どうしたんですか？」

Aさん：「昨日まではフツーに動いてたのに。今日突然動かなくなったのよ！」

見てみると、シート名が変更されたいた。

Aさん：「何が原因？またこういう事があると困るから、原因教えてくれる？」

コロ子：「シート名が変更されていたので・・・」

Aさん：「変えてないわよ！」

コロ子：「でも、変わってたから・・・」

Aさん：「変えてないわよ！」

いやいや、変えてるから。コードはシート名指定で書いてて、そのシート名と実際のシート名が違っている。

Aさん：「あっ。そう言えば、一つ心当たりがあるわ。データがいっぱいになってきたら古いデータを別のシートに移したの。コピーしたらダメなの？」

コロ子：「コピーしても大丈夫ですけど、きっとその時にシート名も変えちゃったのかもしれないですね。」

Aさん：「変えてないわよ！」

自覚症状なし。手強い。

シートをよく見てみるとこんな感じ。

どうやら、メインデータは一番左に置いて、古いデータや個別に見たいデータは右側に足していくパターンらしい。そして無意識のうちにシート名を変更することがある。
ということで

・シート名が存在するか確認し、あればシート名指定にする。
・もし存在しなければ、一番左のシートを指定する。

Dim buf As Worksheet
Dim flg As Boolean

'「測定データ」というシート名があるか確認する
For Each buf In Worksheets

    If buf.Name = "測定データ" Then
        flg = True
    End If

Next buf


Dim ws As Worksheet

If flg Then

    '「測定データ」シートがあればシート指定
    Set ws = Worksheets("測定データ")

Else

    'なければ一番左のシートを指定する
    Set ws = Worksheets(1)

End If

これでどう？
若干、心理戦的な感じが危ないかな。まーこれでしばらく様子を見よう。

コロ子：「とりあえず直しましたけど、シート名変えないでくださいね。」

Aさん：「だからっ！変えてないわよ！」

それにしてもWorksheets(1)って位置指定方法、おなじみだけど初めて使った。
こういう時の為の方法なのかな？
シートの指定方法、悩ましい。

VBA 連動したプルダウンを作る ＆ 自動登録

こんにちは。
派犬事務員のコロ子です。

連動したプルダウンリストを作る

ブロック、都道府県、会社名、支店名からできている「店舗情報」シートがある。

この店舗情報を元に、このようなデータを入力したい。

「けっこう入力が大変」と渡された状態ではブロックがプルダウンリストで選択できる。

そして、プルダウンを選択して都道府県を入力しようとすると

選択したブロック以外の都道府県もプルダウンリストに出てしまう。
そして、会社名、支店名はプルダウンリストにするのを諦めたようで手入力になっている。

確かに入力が大変なので「店舗情報」のシートより連動して絞れるプルダウンリストがあるといいかも。

また、店舗情報は随時追加される。

条件としては
①ブロック、都道府県、会社名、支店名がプルダウンリストより選択できるようにする。
②新規の追加ができるようにする。
　・プルダウンリスト以外に手入力ができるようにする。
　・手入力したデータが「店舗情報」シートに追加される。

では、早速作成してみよう。

コード

【Sheet1(データ)モジュール】

'自動登録用に最初のセルの内容を記憶しておく
Private BeforCompany As String
Private BeforBranch As String


Private Sub Worksheet_SelectionChange(ByVal Target As Range)

'1行目はタイトル行なので無視する
If Target.Row = 1 Then
    Exit Sub
End If

Dim bloclData As String

'手入力したて出たエラーを無視する
On Error Resume Next

'ブロックの列が選択されたとき
If Target.Column = 2 Then

    bloclData = Sheet2.Block()
    
    'プルダウンリストをリセット
    Target.Validation.Delete
    
    'リストを追加
    Target.Validation.Add Type:=xlValidateList, _
                          Operator:=xlEqual, _
                          AlertStyle:=xlValidAlertWarning, _
                          Formula1:=bloclData

'都道府県の列が選択されたとき
ElseIf Target.Column = 3 Then

    'ブロック名が入っているときのみ
    If Target.Offset(0, -1).Value <> "" Then

        bloclData = Sheet2.Prefectures(Target)
        
        'プルダウンリストをリセット
        Target.Validation.Delete
        
        'リストを追加
        Target.Validation.Add Type:=xlValidateList, _
                              Operator:=xlEqual, _
                              AlertStyle:=xlValidAlertWarning, _
                              Formula1:=bloclData
    
    End If
    
'会社名の列が選択されたとき
ElseIf Target.Column = 4 Then

    '都道府県名が入っているときのみ
    If Target.Offset(0, -1).Value <> "" Then

        bloclData = Sheet2.company(Target)
        
        'プルダウンリストをリセット
        Target.Validation.Delete
        
        'リストを追加
        Target.Validation.Add Type:=xlValidateList, _
                              Operator:=xlEqual, _
                              AlertStyle:=xlValidAlertInformation, _
                              Formula1:=bloclData
    
    End If

'支店名の列が選択されたとき
ElseIf Target.Column = 5 Then

    'データ追加の為に記憶しておく
    If Target.Value <> "" Then
    
        BeforCompany = Target.Offset(0, -1)
        BeforBranch = Target.Value
    
    End If


    '都道府県名、会社名が入っているとき
    If Target.Offset(0, -1).Value <> "" And Target.Offset(0, -2).Value <> "" Then

        bloclData = Sheet2.branch(Target)
        
        'プルダウンリストをリセット
        Target.Validation.Delete
        
        'リストを追加
        Target.Validation.Add Type:=xlValidateList, _
                              Operator:=xlEqual, _
                              AlertStyle:=xlValidAlertInformation, _
                              Formula1:=bloclData
    
    
    End If
    
'数の列が選択されたとき
ElseIf Target.Column = 6 Then

'店舗情報シートにない会社を登録する

    If Target.Offset(0, -1).Value <> "" Then
    
        Call Sheet2.Add_Data(BeforCompany, BeforBranch, Target.Row)
    
    End If
    
End If

End Sub

【Sheet2(店舗情報)モジュール】

Function Block() As String
'ブロック名をカンマ(,)で区切った文字列を返す

Dim dic As Dictionary
Set dic = New Dictionary
Dim str As String

Dim i As Long

For i = 2 To Cells(Rows.Count, 1).End(xlUp).Row

    'ブロック名の重複を確認する
    If dic.Exists(Cells(i, 1).Value) = False Then

        dic.Add Cells(i, 1).Value, i
        str = str & Cells(i, 1).Value & ","
        
    End If

Next i

If str = "" Then
    Block = ""
Else

    '最後の,を取る
    Block = Left(str, Len(str) - 1)

End If

End Function


Function Prefectures(Target As Range) As String
'件名をカンマ(,)で区切った文字列を返す

Dim dic As Dictionary
Set dic = New Dictionary
Dim str As String

Dim i As Long

For i = 2 To Cells(Rows.Count, 1).End(xlUp).Row

    'データシートのブロック名と店舗情報のブロック名が同じとき
    If Sheet1.Cells(Target.Row, 2).Value = Cells(i, 1).Value Then

        '都道府県名の重複を確認する
        If dic.Exists(Cells(i, 2).Value) = False Then
    
            dic.Add Cells(i, 2).Value, i
            str = str & Cells(i, 2).Value & ","
    
        End If
    
    End If

Next i


If str = "" Then
    
    Prefectures = ""

Else
    '最後の,を取る
    Prefectures = Left(str, Len(str) - 1)
End If

End Function


Function company(Target As Range) As String
'会社名をカンマ(,)で区切った文字列を返す

Dim dic As Dictionary
Set dic = New Dictionary
Dim str As String

Dim i As Long

For i = 2 To Cells(Rows.Count, 1).End(xlUp).Row

    '都道府県が同じとき
    If Sheet1.Cells(Target.Row, 3).Value = Cells(i, 2).Value Then

        '会社名の重複を確認する
        If dic.Exists(Cells(i, 3).Value) = False Then
    
            dic.Add Cells(i, 3).Value, i
            str = str & Cells(i, 3).Value & ","
    
        End If
    
    End If

Next i

If str = "" Then

    company = ""

Else

    '最後の,を取る
    company = Left(str, Len(str) - 1)

End If

End Function


Function branch(Target As Range) As String
'支店名をカンマ(,)で区切った文字列を返す

Dim dic As Dictionary
Set dic = New Dictionary
Dim str As String

Dim i As Long

For i = 2 To Cells(Rows.Count, 1).End(xlUp).Row

    'データシートと店舗情報の都道府県と会社名が同じ時
    If Sheet1.Cells(Target.Row, 3).Value = Cells(i, 2).Value And _
       Sheet1.Cells(Target.Row, 4).Value = Cells(i, 3).Value Then

        '支店名の重複を確認する
        If dic.Exists(Cells(i, 4).Value) = False Then
    
            dic.Add Cells(i, 4).Value, i
            str = str & Cells(i, 4).Value & ","
    
        End If
    
    End If

Next i


If str = "" Then

    branch = ""

Else

    '最後の,を取る
    branch = Left(str, Len(str) - 1)

End If

End Function

Sub Add_Data(company As String, branch As String, r As Long)

Dim flg As Boolean
Dim lastRow As Long


lastRow = Cells(Rows.Count, 1).End(xlUp).Row

Dim i As Long
For i = 2 To lastRow

    '会社名と支店名がマッチするものがすでにある場合
    If Cells(i, 3).Value = company And _
       Cells(i, 4).Value = branch Then
    
        flg = True
        Exit For
    
    End If
    
Next i

If flg Then

    '上書き
    Cells(i, 1).Value = Sheet1.Cells(r, 2).Value
    Cells(i, 2).Value = Sheet1.Cells(r, 3).Value
    Cells(i, 3).Value = Sheet1.Cells(r, 4).Value
    Cells(i, 4).Value = Sheet1.Cells(r, 5).Value

Else

    '最終行に追加
    Cells(lastRow + 1, 1).Value = Sheet1.Cells(r, 2).Value
    Cells(lastRow + 1, 2).Value = Sheet1.Cells(r, 3).Value
    Cells(lastRow + 1, 3).Value = Sheet1.Cells(r, 4).Value
    Cells(lastRow + 1, 4).Value = Sheet1.Cells(r, 5).Value


End If

    'ソートする
    With Me.Sort
        .SortFields.Clear
        .SortFields.Add Key:=Range("A1"), Order:=xlAscending
        .SortFields.Add Key:=Range("B1"), Order:=xlAscending
        .SortFields.Add Key:=Range("C1"), Order:=xlAscending
        .SortFields.Add Key:=Range("D1"), Order:=xlAscending
        .SetRange UsedRange
        .Header = xlYes
        .Apply
    End With

End Sub

Sheet1(データ)モジュールでは
Worksheet_SelectionChange イベントでセルの選択が変更されたらマクロを実行する。ちょっとコードが長くなっちゃったけど、どの列が選択されたかを判定している。

ポイントは
リストを追加するValidation.Addメソッドで
AlertStyle:=xlValidAlertWarning
にするとアラートが出て、手入力できる。
また
On Error Resume Nextステートメントで、手入力したときにプルダウンリストが作成できないエラーをスキップする。

Sheet2(店舗情報)モジュールでデータの重複を排除するためにDictionaryオブジェクトを使用した。AddメソッドでKeyにプルダウンリストにするデータ入れてExistsメソッドで重複を確認する。Itemは必要ないけど省略できなかったので、適当にカウンタ変数iを入れた。
もっと良い方法があるのかもしれないけど、Dictionaryオブジェクトしか思いつかなかったので。

新規登録はデータシートの6列目（数の列）が選択されたとき「店舗情報」シートに店舗名と支店名が同じものがなければデータを追加する。また最初に入っている値をモジュール変数に入れて記憶しておけば、データの変更があった時に上書きをする。

完成！連動したプルダウン

選択したブロックの都道府県が選択できる

選択した都道府県の会社が選択できる

選択した会社の視点が選択できる

自動登録

プルダウンリストににない場合は手入力OK

↓
手入力したデータが「店舗情報」シートに追加される

連動したプルダウンはエクセルに詳しい人なら関数でできるかもしれないけど（データを作る手間かVBAを書く手間か）だけど、自動登録はVBAでしかできないから、やっぱりVBAは偉いな～。

VBA オブジェクト名を変数名で宣言したら表示がおかしい！

こんにちは。
派犬事務員のコロ子です。

オブジェクト名を変数名で宣言したらオブジェクト名の表示がおかしくなった。

こんなコードがあったとして

「Rows」というオブジェクト名があるのにもかかわらず、どうしたことか「rowS」という変数名を宣言してしまった。

もちろんコンパイルエラー。
「あっ！しまった。VBAって大文字小文字の区別ないんだよね？」
と思ってよく見たら、全ての「Rows」が「rowS」に変更されている！！

慌てて
Dim rowS As Long 　を
Dim rowA As Long　に変更してもオブジェクト名の表示は「rowS」のまま。

「えっー！！こんなことあるの？？？」
他のモジュールを確認しても全て「rowS」になっている。

しかし、表示は「rowS」でおかしいけど、普通に動く。
その後のコードを書くもインテリセンス表示は「Rows」なのに、選択したとたん「rowS」になる。

直し方

「VBEエディタ壊れちゃった・・・」
パソコンを再起動しても直らないし、気持ち悪いけど動くからまぁいいや、と思いかけたとき、ふと思って再度Rowsで宣言してみた。

直った！！
Dim Rows As Long

と書いたとたん、全ての「rowS」が「Rows」に一瞬で変更された。

こんなことあり？

VBA Dirはネストできない？

こんにちは。
派犬事務員のコロ子です。

Dirの謎？

先日、こんな依頼があった。

ある「フォルダA」に下記のようなエクセルファイルがある。

別の「フォルダB」に下記のようなフォルダがある。

フォルダAのエクセルファイルをフォルダBの同じ名前のフォルダに入れたい。
その数500～600個。

Aさん：「急ぎでも必須でもないけど、フォルダの中身を整理したいんだよね。でも手作業でやるのは大変過ぎるんだよね。なんとかならない？」

コロ子：「こんなのなら簡単です。すぐできます！」

めっちゃ安請け合して、１回使うだけだから雑でもいいからささっと作って、ちゃっちゃっと終わらせようとこんなコードを書いてみたところ・・・。

Sub Move_File()

Dim fileName As String
'フォルダAの中のファイル名を取得
fileName = Dir(ThisWorkbook.Path & "\フォルダA\*.xlsx")

Do While fileName <> ""

    Dim folderName As String
    'フォルダBの中のフォルダ名を取得
    folderName = Dir(ThisWorkbook.Path & "\フォルダB\", vbDirectory)
    
    Do While folderName <> ""
    
        If Left(fileName, 5) = folderName Then
            
            Name ThisWorkbook.Path & "\フォルダA\" & fileName As _
                 ThisWorkbook.Path & "\フォルダB\" & folderName & "\" & fileName
        
        End If
        folderName = Dir()

    Loop
    
    fileName = Dir()

Loop

End Sub

あれ・・・？
上手くいかない。最初の一つしかできてない？

理由が良く分からないので分解して確認してみる。

フォルダA内のファイル名を取得する

Sub test1()

Dim fileName As String

fileName = Dir(ThisWorkbook.Path & "\フォルダA\*.xlsx")

Do While fileName <> ""

    Debug.Print fileName
    fileName = Dir()

Loop

End Sub

イミディエイトウインドウ

AAA-1-ファイル.xlsx
AAA-2-ファイル.xlsx
AAA-3-ファイル.xlsx
AAA-4-ファイル.xlsx
BBB-1-ファイル.xlsx
BBB-2-ファイル.xlsx
BBB-3-ファイル.xlsx

問題なし。

フォルダBのフォルダ名を取得する

Sub test2()

Dim folderName As String
folderName = Dir(ThisWorkbook.Path & "\フォルダB\", vbDirectory)

Do While folderName <> ""

    Debug.Print folderName
    folderName = Dir()

Loop

End Sub

イミディエイトウインドウ

.
..
AAA-1
AAA-2
AAA-3
AAA-4
BBB-1
BBB-2
BBB-3

これも問題なし。
（「.」は自分自身のフォルダ、「..」は1つ上のフォルダ。Dir(パス, vbDirectory)でフォルダを取得すると「.」と「..」も取得する。）

あとは、疑わしきはファイルの移動
「Name パス\古い名前 As パス\新しい名前」で移動する。
試しに1つやってみる。

Sub test3()

Name ThisWorkbook.Path & "\フォルダA\AAA-1-ファイル.xlsx" As _
     ThisWorkbook.Path & "\フォルダB\AAA-1\AAA-1-ファイル.xlsx"

End Sub

これも問題なし。

でもやっぱりDirが疑わしいので調べたところ

fileName = Dir(パターン)
最初にパターンに一致するファイル（フォルダの名前etc）を文字列で返す。
fileName = Dir()
次にパターンに一致するファイル（フォルダの名前etc）を文字列で返す。

途中で違うパターンを挟んでみると

Sub test4()

Dim fileName As String

'パターンA　フォルダAの中身
fileName = Dir(ThisWorkbook.Path & "\フォルダA\*.xlsx")
Debug.Print fileName

fileName = Dir()
Debug.Print fileName


'途中で別のパターンを挟む
'パターンB　フォルダBの中身
Dim folderName As String

folderName = Dir(ThisWorkbook.Path & "\フォルダB\", vbDirectory)
Debug.Print folderName

folderName = Dir()
Debug.Print folderName

folderName = Dir()
Debug.Print folderName

folderName = Dir()
Debug.Print folderName

End Sub

イミディエイトウインドウ

AAA-2-ファイル.xlsx
AAA-3-ファイル.xlsx
.
..
AAA-1
AAA-2

途中でパターンを変えると最初のパターンは上書きされてなくなっちゃう！

それにしてもDirって変な関数、というか奥が深い。

う～ん、こういう場合は諦めてFSO（FileSystemObject）を使うしかないかぁ。
（FSOを使う場合は「Microsoft Scripting Runtime」の参照設定を忘れずに！）

DirとFSOと組み合わせ
一回だけ使う分にはこれで十分。

Sub test5()

'DirとFSOと組み合わせ

Dim fileName As String

'フォルダA中のファイルはDirで取得
fileName = Dir(ThisWorkbook.Path & "\フォルダA\*.xlsx")

Do While fileName <> ""

    'フォルダB中のフォルダはFSOで取得
    Dim fso As FileSystemObject
    Set fso = New FileSystemObject
    
    Dim folderPath As Folder
    Set folderPath = fso.GetFolder(ThisWorkbook.Path & "\フォルダB\")
    
    Dim folderName As Folder
    
    For Each folderName In folderPath.SubFolders

        If Left(fileName, 5) = folderName.Name Then
        
            Name ThisWorkbook.Path & "\フォルダA\" & fileName As folderName & "\" & fileName
            Exit For
        
        End If
    
    Next folderName

    
    fileName = Dir()

Loop


End Sub

統一感を出すために両方FSOを使う場合

Sub test7()

Dim fso As FileSystemObject
Set fso = New FileSystemObject

Dim filePath As Folder
Set filePath = fso.GetFolder(ThisWorkbook.Path & "\フォルダA\")

Dim fileName As File

For Each fileName In filePath.Files

    Dim folderPath As Folder
    Set folderPath = fso.GetFolder(ThisWorkbook.Path & "\フォルダB\") 
    
    Dim folderName As Folder
    
    For Each folderName In folderPath.SubFolders

        If Left(fileName.Name, 5) = folderName.Name Then
        
            Name filePath & "\" & fileName.Name As folderName & "\" & fileName.Name
            Exit For
        
        End If
    
    Next folderName

Next fileName

End Sub

教訓

簡単だと思ったのに、結局つまずいてすぐにできなかった。
「すぐできます」とか言うのはやめるべし！

ノンプログラマーの特権？

こんにちは。
派犬事務員のコロ子です。

新しい部署での仕事

4月から異動になってそろそろ2ヶ月。何をしているかというと「こーゆーの作って」の頼まれ仕事をしている。
事務仕事のルーチンワークは持たず、毎日VBA三昧。ノンプログラマーとしては最高の環境！？なのかな。

上司から分厚いファイルを渡されて「特にイメージはないんだけど、これをいい感じに作って」と言われて悩む。
う～ん、やっぱりAccess案件かなぁ。Access苦手なんだよなぁ。
最初の何日かはただ資料を眺めるだけで何も進まない。考えがまとまらず、ちょっと作ってはボツ、ちょっと作ってはボツを繰り返す。
本当に成果ゼロ。焦る。
今までは事務仕事を持っていたから、マクロ作成の時間の捻出に苦労したけど、進まなくてもその日の仕事の成果ゼロはなかった。
そしてほんのちょっと中途半端にデータベースについて勉強したせいで、リレーションとか正規化とかを意識して、どこから手を付けていいのか分からなくなった。
焦るばかりで何も進まない。
期日の半分くらいが過ぎて焦りが限界に達し「もう、これ以上は無理！正しいとか間違っているとかどーでもいい！」半ばやけになって作り始めた。
テーブル3個くらい作った時点で上司に「Accessで作ってます」と無意味な中間報告をして無理やり進める。なんとか期日に間に合い、とりあえずOKを貰った。
そして後から「あーしたい、こーしたい」がいろいろ出てきて無理やり後付けで推し進めて、スパゲッティのように複雑にからまりまくった謎のデータ構造に仕上がった。
こんなんで、後々メンテナンスできるのだろうか。
お給料の値上げ交渉どころか、お金貰えるレベルに至っていないことがいたたまれない。
どうすれば良かったのだろう。正解が分からない。

過去を振り返る

そして気になる事がある。
今までもAccessを使っていたけど、リレーションとか正規化とか、そんな事は全く知らず、全然デタラメに作っていた。
前の部署で15年以上前に作ったAccessは今でも普通に使えている。
さらに言えば、みんな毎日使っていて、そのAccessがなければ仕事にならないくらいのメインデータベースだ。
そのデータベースを正しく作り直すとしたらどうだろうか？
リレーションとか正規化とかきちんとしたら、なんか使いにくくなりそうな気がする。
どうやっていいのかさっぱり分からない。
もしかしたらデーターベース的に正しくないから使える物になっているのではないか？
どの辺が正しくないかというと、正規化ななんて知らなかったからもちろん非正規化。
リレーションシップには
一対多
多対多
一対一
があるみたいだけど、どれにも当てはまらない。
強いて言うなら一対一の変則系？
お店とかではないので、よく本に載っている例題が参考にならない。
リレーションシップというより、その部署で働いている人なら誰でも知っている共通認識で繋がっている。でもその部署だけのものなので十分使えている。

もしプロが作るならそうはいかない。
みんなの共通認識をシステムに落とし込まなければならない。
プロなら100％正しく作る事が求められる。
コロ子のAccessは正しくないおかげで
・メインデータないのにサブデータが入力できたり
・本来ユニークなはずのデータが重複できたり
・マスターテーブルにないものが入力できたり
あり得ないことが、意外と融通が利いて便利だったりする。
プロには絶対作れない。

Excelだって表計算ソフトだけど、絵を描く人もいる。
やりたい事が出来れば、使い方が正しいとか間違っているとかは関係ない。
使い方は自由だ。

もしかしたら、
自由な使い方ができるのはノンプログラマーの特権
なのかもしれない。

Excelで組織図を作成（２）兼任の場合と集計

こんにちは。
派犬事務員のコロ子です。

前回書いた「Excelで組織図を作成する」の続き。
組織図を作成した後に、
「○○さんは今年度からA課とB課を兼任することになった」とか
「組織図の下の方に集計の表を載せたい」とか
必ず何か出てくる。
先に言ってくれればいいのに、と思うけど、完成図を見てから思い出すんだろうな、きっと。

兼任の場合は？

例えば、コロ子が第一部のA課とB課を掛け持ちすることになった場合
名簿テーブルのデータを追加する

一覧表に同じ人がダブっているのが気持ち悪く感じるかもしれないけど、こうすればコードはそのままで複数部署に所属できる。

集計

兼任の列を追加して配分を入力。

1÷重複数を計算するマクロを作成したけど
配分が「A部署：B部署＝3：7」とか、3部署掛け持ちで割り切れない、などで結局は手入力。

別シートに集計表を作る

ここでもマクロを作りたくなるけど、関数の方が簡単なのでSUMIFS関数を使う。
第一部、A課、A区分の合計は
=SUMIFS(名簿!$H:$H, 名簿!$F:$F, "第一部", 名簿!$G:$G, "A課", 名簿!$D:$D, "A")

集計表を張り付け

この集計表を図として貼り付けする

表をコピーする

組織図の図を貼りたい位置で右クリックして
「その他の貼り付けオプション」→「リンクされた図」を選択して張り付ける

集計表も図なので好きな位置に移動できる。

図のプロパティを
「セルに合わせて移動やサイズを変更しない」にする。

こんなふうに列が増えたり減ったりしても形が崩れない。

Tips

【図形をまとめて選択する。】

「ホームタブ」→「検索と選択」→「オブジェクトの選択」

マウスでドラッグした範囲の図形が選択される。

まとめて移動する時に便利！

【図形の位置を揃える】

位置を揃えたい図形を選択して
「書式タブ」→「配置」より図形の位置を揃えられる

Excelで組織図を作成

こんにちは。
派犬事務員のコロ子です。

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」
オブジェクト名はプロパティウインドウから変更できます。