[VBA]2つの異なるリストを1つにまとめる

質問

こちらの識者の方々にはいつもお世話になっています。
Excel VBAの質問です。

環境は下記になります。
OS=windows7 Pro SP1
Office=Excel2010(14.0.7128.5000)

下記のような2つのExcelベースのDBがあり、一部のフィールドは重複しています。
レコードも一部重複しています。
それを一つにまとめて、DB（完成形）のようにしたいのですが、どのようなコードが適していますでしょうか？
一旦配列に取り込んで、連想配列を使って・・・と考えたのですが、新しいレコードを配列内に追加するのはいいとしても、
Filter関数では配列内の要素数までは調べられないようなので、既に存在する要素に対してあたらしい値を格納できないし・・・
となって頓挫しています。

質問に不備不足等ございましたらご指摘ください。
ご面倒お掛けしますがよろしくお願いします。

回答No.3

keithin · ベストアンサー

実際にヤリタイ事がご相談で掲示されている通りであるなら、エクセルの標準機能だけでさくっと片づけてしまいます。

sub macro1()
　dim db1 as range
　dim db2 as range
　dim Target as range

’以下の初期化はご質問とは関係ない個所なので自力で適切に設定する事
　set db1 = worksheets("Sheet1").range("A1").currentregion
　set db2 = worksheets("Sheet2").range("A1").currentregion
　set Target = worksheets("Sheet3").range("A1")

’統合
　target.consolidate _
　　sources:=array( _
　　　db1.parent.name & "!" & db1.address(true,true,xlr1c1), _
　　　db2.parent.name & "!" & db2.address(true,true,xlr1c1) _
　　　), _
　　function:=xlsum, toprow:=true, leftcolumn:=true, createlinks:=false

’後に必要に応じて表示形式等を整える事
end sub

お礼

標準機能であったんですね！
たった1行で解決できるなんて今まで悩んでたことがうそのようです。
本当にありがとうございました。
回答1の方と迷いましたが、より平易で単純なこちらをベストアンサーにしたいと思います。

回答No.2

kagakusuki

>質問に不備不足等ございましたらご指摘ください。

　万が一、DB1とDB2の両表に共通する日付があった場合にはどうすれば宜しいのでしょうか?
　DB1に入力されている数値とDB2に入力されている数値の合計値をDB（完成形）に書き込めば宜しいのでしょうか?
　もし、合計値で良いとした場合でも、数値ではなく文字列が入力されていた場合にはどうすれば宜しいのでしょうか?(文字列は無視して、数値の方のデータのみを書き込めば良いのでしょうか?)
　それとも、どちらか片方のデータの方を優先して書き込む様にすれば宜しいのでしょうか?
　もし、どちらか片方のデータの方を優先するとした場合でも、同一品目、導一日付に該当するセルにおいて、優先するDBの方が空欄で、優先しないDBの方にのみ何か値が入力されていた場合にはどうすれば宜しいのでしょうか?

補足

ご指摘ありがとうございます。

>万が一、DB1とDB2の両表に共通する日付があった場合にはどうすれば宜しいのでしょうか?

言葉足らずですみません。
共通するフィールドがないことは担保されています。

回答No.1

real beatin（@realbeatin）

こんにちは。

Scripting.DictionaryとかADODB.RecordSetとかAraayListとか、
途中までコードを書いてはみたけど必要以上に複雑になりそうなので止め、
Excelシートそのものを配列に見立て、
【名前の定義】と参照演算子のスペースを活用して、
二次元の連想配列、、、的なものを、提示することにしました。
（思い付いた中では一番簡単な設計なので、、、。）

もしも、Scripting.Dictionaryで実現したいということなら、
DictionaryオブジェクトのItemはVariantですから、
Itemnに配列を格納するとか、Itemに別のDictionaryオブジェクトを格納するとか、
または、各[商品（名）]・各[日付]に対応した―出力先の行位置・列位置―だけを
Dictionaryオブジェクトに格納するとか、
工夫次第で実現させる方法は数通りあります。
（日付のソートが少し面倒ですが、、、。）

以下、動作条件。
※ご提示の添付画像のシートレイアウトに特化した記述になっています。
※シートモジュールでは正しく機能しない記法になっています。
※各[日付]フィールドのタイトル行の値は、日付値であることが前提です。

不明な点、仕様上の不足、条件の不適合、応用に関する質問、
等ありましたら、補足欄にでも書いてみて下さい。

（＃最近、、、（何年か振りに、、、）このサイトの回答で、
　変数宣言を誤ったままの怪答が流行しているようですが、
　Dim i As Long, j As Long ... などのように行数を省いて書く処を、
　Dim i, j As Long ... のようにデタラメな省略をすると
　型を省略した部分は皆、Variant型になるので、
　期待した動作が得られない場合があります。
　惑わされぬように、真似しないように、
　くれぐれも、注意してくださいませ。）

' ' /////

Sub Re8974417()
Dim rngA As Range
Dim oName As Name
Dim arrSh(), arrMtxSrc()
Dim sNameColTemp As String
Dim nUB As Long, nUBF As Long, nUBN As Long
Dim i As Long, iC As Long, iR As Long, cnR As Long, cnC As Long

　　With Application
　　　　.ScreenUpdating = False
　　　　.EnableEvents = False
　　End With

　　Sheets("DB").Select　'　要指定◆出力先シート（例１）
　　Cells.CurrentRegion.Clear　'　　　　　　　　（例１）
'　　Worksheets.Add　'　要指定◆出力先シート（例２）

　　arrSh() = VBA.Array(Sheets("DB2"), Sheets("DB1"))　'　要指定◆ソース各テーブルの親シートオブジェクトを配列で
　　nUB = UBound(arrSh())　'　ソーステーブルの数（0 origin）
　　ReDim arrMtxSrc(nUB)　'　各ソーステーブルの値（二次元配列）を格納する配列（二段階配列）

　　cnR = 2
　　cnC = 2
　　For i = 0 To nUB　'　ソース各テーブルの親シート毎にループ
　　　　With arrSh(i).Cells.CurrentRegion
　　　　　　With .Range("A2", .Cells(.Cells.Count))

' ' 各ソーステーブルの値（二次元配列）を配列に格納（二段階配列）
　　　　　　　　arrMtxSrc(i) = .Value

' ' フィールド：各[日付]（重複を含む）をＢ列３行め以下に（一旦、縦方向に）列挙
　　　　　　　　For iC = 2 To UBound(arrMtxSrc(i), 2)
　　　　　　　　　　cnC = cnC + 1
　　　　　　　　　　Cells(cnC, 2) = arrMtxSrc(i)(1, iC)
　　　　　　　　Next iC

' ' レコード：　[商品（名）]（重複を含む）をＡ列３行め以下に列挙
　　　　　　　　For iR = 2 To UBound(arrMtxSrc(i))
　　　　　　　　　　cnR = cnR + 1
　　　　　　　　　　Cells(cnR, 1) = arrMtxSrc(i)(iR, 1)
　　　　　　　　Next iR
　　　　　　End With
　　　　End With
　　Next i
　　Erase arrSh()

' ' レコード：　[商品（名）]　重複を削除
　　Range("A:A 2:" & cnR).RemoveDuplicates Columns:=1, Header:=xlNo

　　With Range("B:B 3:" & cnC)
' ' フィールド：各[日付]　重複を削除（縦方向）
　　　　.RemoveDuplicates Columns:=1, Header:=xlNo
' ' フィールド：各[日付]　ソート（縦方向）
　　　　.Sort Key1:=.Cells(1), Order1:=xlAscending, Orientation:=xlSortColumns, Header:=xlNo
' ' フィールド：各[日付]　コピー（縦方向）
　　　　.Copy
' ' フィールド：各[日付]　・行列を入れ替えて・値のみ　貼付け
　　　　Range("B2").PasteSpecial Paste:=xlPasteValues, Transpose:=True
　　　　.Clear
　　End With

　　With Cells.CurrentRegion
' ' フィールド：各[日付]　書式／表示形式を指定
　　　　.Cells(2, 2).Resize(, .Columns.Count - 1).NumberFormat = "m/d;@"

　　　　With .Cells(3, 2).Resize(.Rows.Count - 2, .Columns.Count - 1)
' ' フィールド：各[日付]　に対応する【名前の定義】を設定
　　　　　　For Each rngA In .Columns
　　　　　　　　ActiveSheet.Names.Add Name:=Format$(rngA.Cells(0), "日付yymmdd"), RefersTo:=rngA
　　　　　　Next

' ' レコード：　[商品（名）]　に対応する【名前の定義】を設定
　　　　　　For Each rngA In .Rows
　　　　　　　　ActiveSheet.Names.Add Name:=rngA.Cells(1, 0), RefersTo:=rngA
　　　　　　Next
　　　　End With

　　　　With .Cells(2, 1).Resize(.Rows.Count - 1, .Columns.Count)
' ' 出力先テーブルに罫線を設定
　　　　　　.Borders.LineStyle = xlContinuous
　　　　　　.Select
　　　　End With
　　End With

　　Cells(1) = "DB(完成形)"　'　要指定◆出力先テーブル名
　　Cells(2, 1) = "商品"　'　要指定◆　[商品（名）]フィールド名

　　For i = 0 To nUB　'　各ソーステーブルの値（二次元配列）毎にループ

　　　　For iC = 2 To UBound(arrMtxSrc(i), 2)　'　各[日付]フィールド毎にループ
　　　　　　sNameColTemp = Format$(arrMtxSrc(i)(1, iC), "日付yymmdd")

　　　　　　For iR = 2 To UBound(arrMtxSrc(i))　'　各[商品(名）]毎にループ

' ' 【名前の定義】と参照演算子のスペースを活用して、
' ' Range("日付140401" & " " & "りんご") のようにセル範囲の積和（交点）を指定することで
' ' 連想配列の代用として機能させる
' ' ■同じ[商品(名）][日付]のデータが複数ある可能性に備え、仮に、加算する仕様、を選んだ■
　　　　　　　　With Range(sNameColTemp & " " & arrMtxSrc(i)(iR, 1))
　　　　　　　　　　.Value = .Value + arrMtxSrc(i)(iR, iC)
　　　　　　　　End With

　　　　　　Next iR

　　　　Next iC

　　Next i
　　Erase arrMtxSrc()

' ' 【名前の定義】すべて削除
　　For Each oName In ActiveSheet.Names
　　　　oName.Delete
　　Next

　　With Application
　　　　.EnableEvents = True
　　　　.ScreenUpdating = True
　　End With
End Sub

お礼

回答ありがとうございます。
問題なく完成しました。

フィールドとレコードに対して名前を定義し、交わる点に値を入れていく方法ですね。
こんなやり方があったのかと感動しました。
また、.RemoveDuplicatesなど今後も使えそうな知らないものもあったので、それぞれのコードを確認し、今後より発展できるようにがんばりたいと思います。