[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
『VBAで2つのブック間で、キーをもとにデータを取得するコードの修正』（まき）
2つのブック間で、キーをもとにデータを取得するコードに追加修正をしたいですが、
初心者のため行き詰っています。
どなたかコードを教えてください。
◆現在の処理内容
全体状況ブックの明細シートのF列（名前）をチェックブックの所属部署一覧シートの2行目以降から探して該当があった場合に、チェックブックの一番左側のシートにA1セルから転記する。
◆追加修正したい内容
1.全体状況ブックの明細シートのF列（名前）をチェックブックの所属部署一覧シートの2行目以降から探して該当がなかった場合は、チェックブックの一番左側のシートのI2セルから、該当者しなかった方の氏名を転記したい
2.該当者が多い場合縦に長くなってしまうため、部署ごとに1列につき4人ずつ表記になるようにしたい
【検索元】
全体状況ブックの明細シート
（A～AH列までデータがあり、E列（従業員番号）＆F列（名前）が重複しています）
■シートの状態
A～D列 … E列 F列 … G～AH列
11111 田中太郎
11111 田中太郎
22222 佐藤次郎
33333 山田三郎
44444 高橋四郎
55555 吉田五郎
66666 佐々木六郎
66666 佐々木六郎
77777 渡邉七郎
・
・
【検索先】
チェックブックの所属部署一覧シート
（A～G列までデータがあり、1行目は部署名で2行目以降は従業員の名前です。
データの重複はないです）
■シートの状態
A列 B列 … F列
システム一部 … システム七部
田中太郎 渡邉七郎
佐藤次郎
山田三郎
高橋四郎
吉田五郎 ・
佐々木六郎 ・
■シート１に転記希望のイメージ
A列 B列 C列 … I列
システム一部 田中太郎 吉田五郎 伊藤八郎
佐藤次郎 佐々木六郎 中村九郎
山田三郎
高橋四郎
システム七部 渡邉七郎
Sub test1()
Dim mySheet As Worksheet
Dim dicBU As Object, dicNM As Object
Dim keyBU As Variant, keyNM As Variant
Dim myR As Long, myC As Long
Set dicBU = CreateObject("Scripting.Dictionary")
Set mySheet = Workbooks("差分チェックマクロ_ver2.6.xlsm").Worksheets("所属部署一覧")
With mySheet
For myC = 1 To .Cells(1, .Columns.Count).End(xlToLeft).Column
Set dicNM = CreateObject("Scripting.Dictionary")
For myR = 2 To .Cells(.Rows.Count, myC).End(xlUp).Row
dicNM(.Cells(myR, myC).Value) = Empty
Next myR
Set dicBU(.Cells(1, myC).Value) = dicNM
Next myC
End With
Set mySheet = Workbooks("社内工数投入状況_全体 .xlsx").Worksheets("明細")
With mySheet
For Each keyBU In dicBU.Keys
Set dicNM = dicBU(keyBU)
For Each keyNM In dicNM.Keys
Debug.Print keyNM
If WorksheetFunction.CountIf(.Columns(6), keyNM) = 0 Then
dicNM.Remove keyNM
End If
Next keyNM
If dicNM.Count = 0 Then
dicBU.Remove keyBU
Else
Set dicBU(keyBU) = dicNM
End If
Next keyBU
End With
With Workbooks("差分チェックマクロ_ver2.6.xlsm")
Set mySheet = Sheets(1)
End With
With mySheet
myR = 1
For Each keyBU In dicBU.Keys
Set dicNM = dicBU(keyBU)
myC = dicNM.Count
keyNM = dicNM.Keys
.Cells(myR, 1).Resize(myC).Value = keyBU
.Cells(myR, 2).Resize(myC).Value = WorksheetFunction.Transpose(keyNM)
myR = myR + myC
Next keyBU
End With
＜ 使用 Excel：Office365、使用 OS：Windows10 ＞
（マナ） 2022/09/13(火) 18:37
（マナ） 2022/09/13(火) 18:56
Sub test1()
Dim mySheet As Worksheet '作業用変数（作業シートを指定）
Dim dicBU As Object '部署用Dictionary
Dim dicNM As Object '作業用変数（部署内のメンバー用Dictionary）
Dim keyBU As Variant '作業用変数（部署）
Dim keyNM As Variant '作業用変数（メンバー）
Dim myR As Long 'カウンタ変数（行）
Dim myC As Long 'カウンタ変数（列）
Set dicBU = CreateObject("Scripting.Dictionary") '部署用Dictionaryを宣言
Set mySheet = Workbooks("差分チェックマクロ_ver2.6.xlsm").Worksheets("所属部署一覧") '作業ワークシート１を設定
With mySheet
For myC = 1 To .Cells(1, .Columns.Count).End(xlToLeft).Column 'シート内1行目各列を巡回
Set dicNM = CreateObject("Scripting.Dictionary") 'メンバー上Dictionaryを初期化
For myR = 2 To .Cells(.Rows.Count, myC).End(xlUp).Row '列ごとに各行を巡回
dicNM(.Cells(myR, myC).Value) = Empty 'メンバー用DictionaryのKeyにメンバー名を入れる（重複避け）
Next myR
Set dicBU(.Cells(1, myC).Value) = dicNM '部署用DictionaryのItemにメンバーDictionaryを入れる
Next myC
End With
Set mySheet = Workbooks("社内工数投入状況_全体 .xlsx").Worksheets("明細") '作業ワークシート２を設定
With mySheet
For Each keyBU In dicBU.Keys '部署用Dictionaryを巡回
Set dicNM = dicBU(keyBU) '作業用変数にItemのメンバーDictionaryを入れる
For Each keyNM In dicNM.Keys '部署内メンバーDictionaryを巡回
Debug.Print keyNM
If WorksheetFunction.CountIf(.Columns(6), keyNM) = 0 Then '作業ワークシート２のF列にメンバー名がなければ
dicNM.Remove keyNM 'メンバーDictionaryから抹消
End If
Next keyNM
If dicNM.Count = 0 Then 'メンバーDictionaryのデータ数が0の場合
dicBU.Remove keyBU '部署用Dictionaryから部署ごと抹消
Else 'データが1以上ある場合は
Set dicBU(keyBU) = dicNM '部署用DictionaryにメンバーDictionaryを再び入れる
End If
Next keyBU
End With
'↑↑↑↑↑↑↑↑↑↑↑↑↑↑↑↑↑↑↑↑ ここまでデータ収集 ↑↑↑↑↑↑↑↑↑↑↑↑↑↑↑↑↑↑↑↑
'↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓ ここから要改修部分 ↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓↓
With Workbooks("差分チェックマクロ_ver2.6.xlsm") '↓「.」が抜けているので←のブックではなくActivesheetなことに注意
Set mySheet = Sheets(1) '作業ワークシート３を設定
End With
With mySheet
myR = 1 '行カウンタを1に設定
For Each keyBU In dicBU.Keys '部署用DictionaryのKey（部署リスト）を巡回
Set dicNM = dicBU(keyBU) '作業用変数にItemのメンバーDictionaryを入れる
myC = dicNM.Count '列カウンタにメンバーDictionaryの要素数を入れる
keyNM = dicNM.Keys '作業用変数にメンバーDictionaryのKey（メンバーリスト）を入れる
.Cells(myR, 1).Resize(myC).Value = keyBU '1列目に部署名を入力
.Cells(myR, 2).Resize(myC).Value = WorksheetFunction.Transpose(keyNM) '2列目にメンバーリストを入力
myR = myR + myC '列カウンタ分行を下げる
Next keyBU
End With
End Sub
練習課題のつもりでまず整理だけしてみました。
後半部分だけ直せば大丈夫？かどうか考えてみたいと思います。
（下手の横好き） 2022/09/13(火) 19:17
（マナ） 2022/09/13(火) 19:38
■１
全体状況ブックの明細シートの並び順は重要ですか？
■２
部署ごとに1列につき4人ずつとのことですが、4人未満の部署の場合でも4行としてよいですか？
また、0人の部署は出力を省略してよいですか？
（もこな２） 2022/09/13(火) 19:42
こんな仕様でよろしいですか
（下手の横好き） 2022/09/13(火) 19:55
Sub test()
Dim ws抽出 As Worksheet
Dim ws一覧 As Worksheet
Dim ws明細 As Worksheet
Dim myList, j As Long, k As Long
Dim dic1 As Object, dic2 As Object, key
Dim bu As String, nm As String
Dim n As Long
Dim r As Long, c As Long
Set ws抽出 = Workbooks("差分チェックマクロ_ver2.6.xlsm").Worksheets(1)
Set ws一覧 = Workbooks("差分チェックマクロ_ver2.6.xlsm").Worksheets("所属部署一覧")
Set ws明細 = Workbooks("社内工数投入状況_全体 .xlsx").Worksheets("明細")
ws抽出.UsedRange.ClearContents
myList = ws一覧.Cells(1).CurrentRegion.Value
Set dic1 = CreateObject("Scripting.Dictionary")
Set dic2 = CreateObject("Scripting.Dictionary")
For k = 1 To UBound(myList, 2)
bu = myList(1, k)
Set dic1(bu) = CreateObject("system.collections.arraylist")
Set dic2(bu) = CreateObject("system.collections.arraylist")
For j = 2 To UBound(myList, 1)
nm = myList(j, k)
If nm <> "" Then
If WorksheetFunction.CountIf(ws明細.Columns(6), nm) Then
dic1(bu).Add nm
Else
dic2(bu).Add nm
End If
End If
Next
Next
r = 1
For Each key In dic1.Keys
c = 1
ws抽出.Cells(r, c).Value = key
Do While dic1(key).Count > 0
c = c + 1
n = Application.Min(dic1(key).Count, 4)
ws抽出.Cells(r, c).Resize(n).Value _
= Application.Transpose(dic1(key).getrange(0, n).toarray)
dic1(key).removerange 0, n
Loop
c = 8
Do While dic2(key).Count > 0
c = c + 1
n = Application.Min(dic2(key).Count, 4)
ws抽出.Cells(r, c).Resize(n).Value _
= Application.Transpose(dic2(key).getrange(0, n).toarray)
dic2(key).removerange 0, n
Loop
r = r + 4
Next
End Sub
（マナ） 2022/09/13(火) 20:46
（マナ） 2022/09/13(火) 21:15
Sub test1()
Dim mySheet As Worksheet '作業用変数（作業シートを指定）
Dim dicBU As Object '部署用Dictionary
Dim dicNM As Object '作業用変数（部署内のメンバー用Dictionary）
Dim dicBU2 As Object
Dim dicNM2 As Object
Dim keyBU As Variant '作業用変数（部署）
Dim keyNM As Variant '作業用変数（メンバー）
Dim myR As Long 'カウンタ変数（行）
Dim myC As Long 'カウンタ変数（列）
'1.作業シート１から部署とメンバーの一覧Dictionaryを作成する
Set dicBU = CreateObject("Scripting.Dictionary") '部署用Dictionaryを宣言
Set mySheet = Workbooks("差分チェックマクロ_ver2.6.xlsm").Worksheets("所属部署一覧") '作業ワークシート１を設定
With mySheet
For myC = 1 To .Cells(1, .Columns.Count).End(xlToLeft).Column 'シート内1行目各列を巡回
Set dicNM = CreateObject("Scripting.Dictionary") 'メンバー上Dictionaryを初期化
For myR = 2 To .Cells(.Rows.Count, myC).End(xlUp).Row '列ごとに各行を巡回
dicNM(.Cells(myR, myC).Value) = Empty 'メンバー用DictionaryのKeyにメンバー名を入れる（重複避け）
Next myR
Set dicBU(.Cells(1, myC).Value) = dicNM '部署用DictionaryのItemにメンバーDictionaryを入れる
Next myC
End With
'2.作業シート２から部署とメンバーの一覧Dictionaryを該当者と非該当者の2つに分ける
Set dicBU2 = CreateObject("Scripting.Dictionary") '非該当者用の部署用Dictionaryを宣言
Set mySheet = Workbooks("社内工数投入状況_全体 .xlsx").Worksheets("明細") '作業ワークシート２を設定
With mySheet
For Each keyBU In dicBU.keys '部署用Dictionaryを巡回
Set dicNM = dicBU(keyBU) '作業用変数にItemのメンバーDictionaryを入れる
Set dicNM2 = dicNM '非該当者用のメンバーDictionaryを複製
For Each keyNM In dicNM.keys '部署内メンバーDictionaryを巡回
Debug.Print keyNM
If WorksheetFunction.CountIf(.Columns(6), keyNM) = 0 Then '作業ワークシート２のF列にメンバー名がなければ
dicNM.Remove keyNM 'メンバーDictionaryから抹消
End If
Next keyNM
If dicNM.Count > 0 Then '該当メンバーDictionaryのリストがある場合
For Each keyNM In dicNM.keys '該当メンバーDictionaryにあるメンバーを
dicNM2.Remove keyNM '非該当者用のメンバーDictionaryから抹消
Next keyNM
End If
Set dicBU(keyBU) = dicNM '部署用Dictionaryに該当メンバーDictionaryを入れる
Set dicBU2(keyBU) = dicNM2 '複製Dictionaryに非該当メンバーDictionaryを入れる
Next keyBU
End With
'3.作業シート３に該当者（B～H列）、非該当者（I～O列）のデータを貼り付ける
With Workbooks("差分チェックマクロ_ver2.6.xlsm") '↓「.」が抜けているので←のブックではなくActivesheetなことに注意
Set mySheet = Sheets(1) '作業ワークシート３を設定
End With
With mySheet
myR = 1 '行カウンタを1に設定
For Each keyBU In dicBU.keys '部署用DictionaryのKey（部署リスト）を巡回
.Cells(myR, 1).Value = keyBU 'A列に部署名を入力
.Cells(myR, 2).Resize(4, 7).Value = SampleFunction(dicBU(keyBU)) 'B～H列に該当メンバーリストを入力
.Cells(myR, 9).Resize(4, 7).Value = SampleFunction(dicBU2(keyBU)) 'I～O列に非該当メンバーリストを入力
myR = myR + 4 '行カウンタを4つ上げる
Next keyBU
End With
End Sub
4×7のリストをつくるSampleFunctionはまた今度にします。
（下手の横好き） 2022/09/13(火) 21:30
もこな２様
■１全体状況ブックの明細シートの並び順は重要ではないです。
■4人未満の部署の場合の行を該当者数にすることはできますか。
また、0人の部署は出力を省略して大丈夫です。
いろいろ注文を付けてしまい、恐縮です。
（まき） 2022/09/14(水) 10:35
Sub test1()
Const GROUP_ROW As Long = 4 '出力領域の単位行数
Dim mySheet As Worksheet '作業用変数（作業シートを指定）
Dim dicBU As Object '作業用変数（部署用Dictionary）
Dim dicNM As Object '作業用変数（部署内のメンバー用Dictionary）
Dim dicBU2 As Object '作業用変数（非該当者部署用Dictionary）
Dim dicNM2 As Object '作業用変数（非該当者メンバー用Dictionary）
Dim keyBU As Variant '作業用変数（部署）
Dim keyNM As Variant '作業用変数（メンバー）
Dim maxCnt As Long '部署ごとの最大メンバー数を把握し転記先を調整するための変数
Dim myR As Long '転記先の行
Dim myC As Long '転記先の、該当者・非該当者を表示する列数
'1.作業シート１から部署とメンバーの一覧Dictionaryを作成する
Set dicBU = CreateObject("Scripting.Dictionary") '部署用Dictionaryを宣言
Set mySheet = Workbooks("差分チェックマクロ_ver2.6.xlsm").Worksheets("所属部署一覧") '作業ワークシート１を設定
With mySheet
For myC = 1 To .Cells(1, .Columns.Count).End(xlToLeft).Column 'シート内1行目各列を巡回
Set dicNM = CreateObject("Scripting.Dictionary") 'メンバー上Dictionaryを初期化
For myR = 2 To .Cells(.Rows.Count, myC).End(xlUp).Row '列ごとに各行を巡回
dicNM(.Cells(myR, myC).Value) = Empty 'メンバー用DictionaryのKeyにメンバー名を入れる（重複避け）
Next myR
Set dicBU(.Cells(1, myC).Value) = dicNM '部署用DictionaryのItemにメンバーDictionaryを入れる
If dicNM.Count > maxCnt Then '最大メンバー数がそれまでの最大値より大きい場合は
maxCnt = dicNM.Count '最大メンバー数を更新する
End If
Next myC
End With
'2.作業シート２から部署とメンバーの一覧Dictionaryを該当者と非該当者の2つに分ける
Set dicBU2 = CreateObject("Scripting.Dictionary") '非該当者用の部署用Dictionaryを宣言
Set mySheet = Workbooks("社内工数投入状況_全体 .xlsx").Worksheets("明細") '作業ワークシート２を設定
With mySheet
For Each keyBU In dicBU.keys '部署用Dictionaryを巡回
Set dicNM = dicBU(keyBU) '作業用変数にItemのメンバーDictionaryを入れる
Set dicNM2 = CreateObject("Scripting.Dictionary") '非該当メンバー用Dictionaryを宣言
For Each keyNM In dicNM.keys '部署内メンバーDictionaryを巡回
Debug.Print keyNM
If WorksheetFunction.CountIf(.Columns(6), keyNM) = 0 Then '作業ワークシート２のF列にメンバー名がなければ
dicNM.Remove keyNM 'メンバーDictionaryから抹消
dicNM2(keyNM) = Empty '非該当メンバーDictionaryのKeyににメンバー名を入れる
End If
Next keyNM
Set dicBU(keyBU) = dicNM '部署用Dictionaryに該当メンバーDictionaryを入れる
Set dicBU2(keyBU) = dicNM2 '複製Dictionaryに非該当メンバーDictionaryを入れる
Next keyBU
End With
'3.作業シート３に該当者（B～H列）、非該当者（I～O列）のデータを貼り付ける
With Workbooks("差分チェックマクロ_ver2.6.xlsm") '↓「.」が抜けているので←のブックではなくActivesheetなことに注意
Set mySheet = Sheets(1) '作業ワークシート３を設定
End With
myC = Int(maxCnt / GROUP_ROW) + 1 '該当者・非該当者を表示する列数
With mySheet
myR = 1 '行カウンタを1に設定
For Each keyBU In dicBU.keys '部署用DictionaryのKey（部署リスト）を巡回
.Cells(myR, 1).Value = keyBU 'A列に部署名を入力
.Cells(myR, 2).Resize(GROUP_ROW, myC).Value = _
SampleFunction(dicBU(keyBU), GROUP_ROW, myC) '該当メンバーリストを入力
.Cells(myR, 3).Offset(, myC).Resize(GROUP_ROW, myC).Value = _
SampleFunction(dicBU2(keyBU), GROUP_ROW, myC) '非該当メンバーリストを入力
myR = myR + GROUP_ROW '行カウンタをGROUP_ROW分上げる
Next keyBU
End With
End Sub
Function SampleFunction(objDic As Object, rCnt As Long, cCnt As Long) As Variant()
'objDicのKeysリストをrCnt行×cCnt列の配列に変換する
Dim tmp() As Variant
Dim var As Variant
Dim iR As Long
Dim iC As Long
Dim i As Long
ReDim tmp(1 To rCnt, 1 To cCnt) '仮配列を行×列数で再定義
If objDic.Count > 0 Then '引数のDictionaryが空でなければ
var = objDic.keys 'Keysを配列に入れて
For i = 0 To UBound(var) '要素数分巡回
iC = 1 + (i \ rCnt) '列の値は行数で割った商
If iC > cCnt Then Exit For '列数が配列の上限を超えたら終了
iR = 1 + (i Mod rCnt) '行の値は行数の剰余
tmp(iR, iC) = var(i) '仮配列にKeyを入れる
Next
End If
SampleFunction = tmp
End Function
かなり書き換えてしまいました。
もしかしたら7列固定で行数を変動させた方がよかったのかもしれないと思い始めています。
（下手の横好き） 2022/09/14(水) 13:29
1点、私の説明が分かりにくくてすみません。
やりたいこと1.の該当者なしの検索方法が反対でしたので、
改めて記載します。
これで伝わりますでしょうか。
検索元：全体状況ブックの明細シート、検索KEYはF列（名前）
検索先：チェックブックの所属部署一覧シートの2行目以降
→該当がない場合は、チェックブックのシート1に全体状況ブックの明細シートの該当しなかった方の氏名を転記したい
【検索元：全体状況ブックの明細シート】
A～D列 … E列 F列 … G～AH列
11111 田中太郎
11111 田中太郎
22222 佐藤次郎
99999 ×山×郎
・
・
【検索先チェックブックの所属部署一覧シート】
A列 B列 … F列
システム一部 … システム七部
田中太郎 渡邉七郎
佐藤次郎
・
・
■シート１に転記希望のイメージ → "×山×郎"が明細シートにはあるが、所属部署一覧シートにはない為、該当者なしとして転記したい
A列 B列 … X列
システム一部 田中太郎 ×山×郎
佐藤次郎
（まき） 2022/09/14(水) 14:27
Sub test3()
Dim ws抽出 As Worksheet
Dim ws一覧 As Worksheet
Dim ws明細 As Worksheet
Dim wsTemp As Worksheet
Dim adr1 As String, adr2 As String
Dim c As Range
Dim r As Long
Set ws抽出 = Workbooks("差分チェックマクロ_ver2.6.xlsm").Worksheets(1)
Set ws一覧 = Workbooks("差分チェックマクロ_ver2.6.xlsm").Worksheets("所属部署一覧")
Set ws明細 = Workbooks("社内工数投入状況_全体 .xlsx").Worksheets("明細")
ws一覧.Copy ws抽出
Set wsTemp = ActiveSheet
wsTemp.UsedRange.Offset(1).ClearContents
adr1 = ws一覧.Cells(1).CurrentRegion.Columns(1).Address(0, 0, , -1)
adr2 = ws明細.Cells(1).CurrentRegion.Columns(6).Address(, , , -1)
wsTemp.Cells(1).CurrentRegion.Rows(2).Formula2 _
= "=filter(" & adr1 & ",countif(" & adr2 & "," & adr1 & "),"""")"
ws抽出.UsedRange.ClearContents
r = 1
For Each c In wsTemp.Cells(1).CurrentRegion.Rows(2).Cells
If c.Value <> "" Then
ws抽出.Cells(r, 1).Value = c.Offset(-1).Value
adr1 = c.Address(, , , -1)
ws抽出.Cells(r, 2).Formula2 = "=WRAPCOLS(" & adr1 & "#,4,"""")"
r = ws抽出.Cells(Rows.Count, 2).End(xlUp).Offset(1).Row
End If
Next
adr1 = ws明細.Cells(1).CurrentRegion.Columns(6).Address(, , , -1)
adr2 = ws一覧.Cells(1).CurrentRegion.Offset(1).Address(, , , -1)
ws抽出.Cells(1, "X").Formula2 _
= "=filter(" & adr1 & ",countif(" & adr2 & "," & adr1 & ")=0,"""")"
ws抽出.UsedRange.Value = ws抽出.UsedRange.Value
ws抽出.Cells(1, "X").Value = "未登録者"
Application.DisplayAlerts = False
wsTemp.Delete
Application.DisplayAlerts = True
End Sub
（マナ） 2022/09/14(水) 19:29
Sub test1()
Const GROUP_ROW As Long = 4 '出力領域の単位行数
Dim mySheet As Worksheet '作業用変数（作業シートを指定）
Dim dicBU As Object '作業用変数（部署用Dictionary）
Dim dicNM As Object '作業用変数（部署内のメンバー用Dictionary）
Dim dicNM2 As Object '作業用変数（非該当者メンバー用Dictionary）
Dim keyBU As Variant '作業用変数（部署）
Dim keyNM As Variant '作業用変数（メンバー）
Dim maxCnt As Long '部署ごとの最大メンバー数を把握し転記先を調整するための変数
Dim myR As Long '転記先の行
Dim myC As Long '転記先の、該当者・非該当者を表示する列数
'1.作業シート１から部署とメンバーの一覧Dictionaryを作成する
Set dicBU = CreateObject("Scripting.Dictionary") '部署用Dictionaryを宣言
Set mySheet = Workbooks("差分チェックマクロ_ver2.6.xlsm").Worksheets("所属部署一覧") '作業ワークシート１を設定
With mySheet
For myC = 1 To .Cells(1, .Columns.Count).End(xlToLeft).Column 'シート内1行目各列を巡回
Set dicNM = CreateObject("Scripting.Dictionary") 'メンバー上Dictionaryを初期化
For myR = 2 To .Cells(.Rows.Count, myC).End(xlUp).Row '列ごとに各行を巡回
dicNM(.Cells(myR, myC).Value) = Empty 'メンバー用DictionaryのKeyにメンバー名を入れる（重複避け）
Next myR
Set dicBU(.Cells(1, myC).Value) = dicNM '部署用DictionaryのItemにメンバーDictionaryを入れる
If dicNM.Count > maxCnt Then '最大メンバー数がそれまでの最大値より大きい場合は
maxCnt = dicNM.Count '最大メンバー数を更新する
End If
Next myC
End With
'2.作業シート２のリストにない者を部署とメンバーの一覧Dictionaryから消し、 ' リストにあるが部署とメンバーの一覧Dictionaryにいない者を非該当者Dictionaryに入れる
Set dicBU2 = CreateObject("Scripting.Dictionary") '非該当者用の部署用Dictionaryを宣言
Set mySheet = Workbooks("社内工数投入状況_全体 .xlsx").Worksheets("明細") '作業ワークシート２を設定
Set dicNM2 = CreateObject("Scripting.Dictionary") '非該当者用Dictionaryを初期化
For myR = 2 To .Cells(.Rows.Count, 6).End(xlUp).Row 'F列各行を巡回
dicNM2(.Cells(myR, 6).Value) = Empty '非該当者用DictionaryのKeyにメンバー名を入れる（重複避け）
Next myR
For Each keyBU In dicBU.keys '部署用Dictionaryを巡回
Set dicNM = dicBU(keyBU) '作業用変数にItemのメンバーDictionaryを入れる
For Each keyNM In dicNM.keys '部署内メンバーDictionaryを巡回
Debug.Print keyNM
If WorksheetFunction.CountIf(.Columns(6), keyNM) = 0 Then '作業ワークシート２のF列にメンバー名がなければ
dicNM.Remove keyNM 'メンバーDictionaryから抹消
ElseIf dicNM2.Exists(keyNM) Then '（F列にメンバー名があって）非該当者用Dictionaryにもメンバー名がある場合（別部署同姓同名対策）
dicNM2.Remove keyNM '非該当者用Dictionaryから抹消
End If
Next keyNM
If dicNM.Count = 0 Then 'メンバーDictionaryのデータ数が0の場合
dicBU.Remove keyBU '部署用Dictionaryから部署ごと抹消
Else 'データが1以上ある場合は
Set dicBU(keyBU) = dicNM '部署用DictionaryにメンバーDictionaryを再び入れる
End If
Next keyBU
End With
'3.作業シート３に該当者、非該当者のデータを貼り付ける
With Workbooks("差分チェックマクロ_ver2.6.xlsm") '↓「.」が抜けているので←のブックではなくActivesheetなことに注意
Set mySheet = Sheets(1) '作業ワークシート３を設定
End With
myC = Int(maxCnt / GROUP_ROW) + 1 '該当者・非該当者を表示する列数
With mySheet
myR = 1 '行カウンタを1に設定
For Each keyBU In dicBU.keys '部署用DictionaryのKey（部署リスト）を巡回
.Cells(myR, 1).Value = keyBU 'A列に部署名を入力
.Cells(myR, 2).Resize(GROUP_ROW, myC).Value = _
SampleFunction(dicBU(keyBU), GROUP_ROW, myC) '該当メンバーリストを入力
myR = myR + GROUP_ROW '行カウンタをGROUP_ROW分上げる
Next keyBU
myR = myR - 1
.Cells(1, 3).Offset(, myC).Resize(myR, myC).Value = _
SampleFunction(dicNM2, myR, myC) '該当メンバーリストの右側に非該当メンバーリストを入力
End With
End Sub
Private Function SampleFunction(objDic As Object, rCnt As Long, cCnt As Long) As Variant()
'objDicのKeysリストをrCnt行×cCnt列の配列に変換する
Dim tmp() As Variant
Dim var As Variant
Dim iR As Long
Dim iC As Long
Dim i As Long
ReDim tmp(1 To rCnt, 1 To cCnt) '仮配列を行×列数で再定義
If objDic.Count > 0 Then '引数のDictionaryが空でなければ
var = objDic.keys 'Keysを配列に入れて
For i = 0 To UBound(var) '要素数分巡回
iC = 1 + (i \ rCnt) '列の値は行数で割った商
If iC > cCnt Then Exit For '列数が配列の上限を超えたら終了
iR = 1 + (i Mod rCnt) '行の値は行数の剰余
tmp(iR, iC) = var(i) '仮配列にKeyを入れる
Next
End If
SampleFunction = tmp
End Function
「該当なし」は部署の一つとするのも一案ですが・・・
（下手の横好き） 2022/09/14(水) 19:56
myR = myR - 1 .Cells(1, 3).Offset(, myC).Resize(myR, myC).Value = SampleFunction(dicNM2, myR, myC)
ここを
myC = Int(dicNM2.Count / GROUP_ROW) + 1 .Cells(myR, 1).Value = "該当なし" .Cells(myR, 2).Resize(GROUP_ROW, myC).Value = SampleFunction(dicNM2, GROUP_ROW, myC)
こうしてください。
（下手の横好き） 2022/09/15(木) 21:43
[ 一覧(最新更新順) ]
YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki.
Modified by kazu.