VBA 重複しない名称単位で集計

自ブックに書いたCodeより実行して

Book(1)とBook(2)をダイアログでエクセルファイルを指定
（Application.GetOpenFilename）

Book(1)とBook(2)のSheet1のデータを自ブックのActiveSheetに
名前ごとで３行単位でデータを記入していくような処理を作成しております（図参照）

こういった場合の処理で、Book(1)とBook(2)の名前の重複しないデータを作り出し、その名前単位でBook(1)とBook(2)の２つの値を覚えこませるような内部処理（変数格納）のうまい仕方について教えて頂きたいです。

Book(1)とBook(2)に記入されている名前は、種類が増えることもあれば、規則だだしく並ばないこともあります。

よろしくお願いします。

No.1 回答者： めぐみん_ 回答日時： 2017/11/30 17:37

たぶん連想配列のDictionaryオブジェクトを使えば可能かも知れません。

が、うちのExcelは古い物ですし、特にダイアログ系は使った事ないのでコードは書けないですね。
（こちらで検証して結果をだせても、そちらで動く保証がないもので）

あとは変数格納に拘らなきゃ、まずはBook１のデータを全部３行置きに書き出し、次にBook２のデータの名前をFindメソッドで検索して該当する名前の
２行目に書き出し、且つ書き出せた（見つかった）名前には空いている列にマークを付ける。
最後にBook２のマークが付いていないデータを貼り付けていくって方法ならいけるのでは？（あくまで未検証の参考意見ですけど）

No.2 回答者： めぐみん_ 回答日時： 2017/11/30 17:39

No.1です。

３行目については画像がよく見えなくて（老眼で）コメント書けませんでした。

No.3 回答者： めぐみん_ 回答日時： 2017/12/01 12:48

取り敢えず自ブックのSheet１とSheet２にデータがあり、Sheet３に纏める方法。

ただし例題なので６ヶ月分としてます。
（r.Range("B1:G1").Value　で６列分）
⇒一応ダミーで検証してみて希望通りに近いのか、確認をお薦めします。

.Range("AB1:AG1").Value
これは空白値を得るためのもので、セル番地は空白であればどこでも良いですが、
セル範囲は上のセル数に合わせて下さい。

あとはBookを選択して開いて閉じてについては、検索すれば見つかるでしょう。
そこからBook名を

　Set ws(0) = Worksheets("Sheet1")
　Set ws(1) = Worksheets("Sheet2")

ここで追加指定すれば行けるんじゃないでしょうかね？

Sub try()
　Dim myDic As Object
　Dim ws(1) As Worksheet
　Dim r As Range, i As Integer
　Dim key

　Set myDic = CreateObject("Scripting.Dictionary")
　Set ws(0) = Worksheets("Sheet1")
　Set ws(1) = Worksheets("Sheet2")

　For i = 0 To 1
　　　With ws(i)
　　　　　For Each r In .Range("A2", .Cells(Rows.Count, 1).End(xlUp))
　　　　　　　If Not myDic.Exists(r.Value) Then
　　　　　　　　　Select Case i
　　　　　　　　　　　Case 0: myDic.Add r.Value, Array(r.Range("B1:G1").Value, .Range("AB1:AG1").Value)
　　　　　　　　　　　Case 1: myDic.Add r.Value, Array(.Range("AB1:AG1").Value, r.Range("B1:G1").Value)
　　　　　　　　　End Select
　　　　　　　Else
　　　　　　　　　myDic(r.Value) = Array(myDic(r.Value)(0), r.Range("B1:G1").Value)
　　　　　　　End If
　　　　　Next
　　　End With
　Next

　With Worksheets("Sheet3")
　　　.Cells.ClearContents
　　　.Range("A1:G1").Value = ws(0).Range("A1:G1").Value
　　　Set r = .Range("A2")
　　　For Each key In myDic.Keys
　　　　　r.Value = key
　　　　　For i = 0 To 1
　　　　　　　r.Offset(i, 1).Resize(, 6).Value = myDic(key)(i)
　　　　　Next
　　　　　r.Offset(2, 1).Resize(, 6).Formula = "=" & r.Offset(0, 1).Address(0, 0) & "-" & r.Offset(1, 1).Address(0, 0)
　　　　　Set r = r.Offset(3)
　　　Next
　End With

　Set myDic = Nothing
　Set ws(0) = Nothing
　Set ws(1) = Nothing
　Set r = Nothing
End Sub

No.4 ベストアンサー 回答者： めぐみん_ 回答日時： 2017/12/01 13:11

No.3 です。

r.Offset(i, 1).Resize(, 6).Value = myDic(key)(i)
Next
r.Offset(2, 1).Resize(, 6).Formula = "=" & r.Offset(0, 1).Address(0, 0) & "-" & r.Offset(1, 1).Address(0, 0)

ここのResizeの『６』も今回の６列というのに関係してます。
１２ヶ月なら１２にして下さい。

この回答へのお礼

コメント遅れましてすみませんでしたm(_ _)m
VBA難しいですね(^_^;)
やっと意図するものができました！
とても勉強になり参考になりました！ありがとうございましたm(_ _)m

お礼日時：2017/12/08 17:08