Excel複数テーブルのマッチング処理について

質問

実現したいことは、以下のような形式で3つの表があり、A列をキーとして添付の結果1、結果2のような出力を別シートに行なうことです。
マッチング処理なのですがなかなか考えがまとまりません。
おそらく関数では難しくVBAで処理するのだろうかと思いますが、経験が浅く手詰まり状態です。
恐れ入りますがご指南のほどよろしくお願いします。

要件と致しましては、

１．A列がキー項目となります。
２．表１、２、３とも列数は固定です。
３．表１はキー（A1、A2）に対し行が一意です。（マスター）
４．表２、３はキー（A1、A2）に対し行が複数行存在します。（必ず１行以上は存在します）
５．上記の場合、添付結果１または結果２のように表示したい。
・A列は値が重複しても同じ値を表示します。
・A列以外は値が重複した場合空欄を表示します。
・列の長さは同一キー項目で一番行数が多いものとなります。

５番の要件で苦慮しています。どうかよろしくお願い致します。

-----------------------------
表１
A列、B列、C列、D列、E列
A1 ,B1 ,C1 ,D1 ,E1
A2 ,B2 ,C2 ,D2 ,E2

表２
A列、F列、G列
A1 ,F1 ,G1
A1 ,F11 ,G11
A2 ,F2 ,G2
A2 ,F22 ,G22
A2 ,F222 ,G222

表３
A列、H列
A1 ,H1
A1 ,H11
A1 ,H111
A2 ,H2
A2 ,H22
A2 ,H222

回答No.3

tom04 · ベストアンサー

No.1・2です。

No.2の補足に
＞以下のように表１（マスタ）に結果出力に常に表示するAa列が追加された場合もご教授願えませんでしょうか？
とありますが、
当方もExcelも常に表示する列というものは判断できません。
ご存知のようにマクロは決まった一連の操作を自動でExcelにやらせるものですので、
後からSheet1に列挿入　→　データ変更　という操作は全くの別物になってしまいます。

どうしても！というコトであればもう一つマクロを追加し、Sheet1の列挿入後そのマクロを実行する程度でしょうかね。

一例です。
↓のマクロを追加し、Sheet1の列挿入　→　挿入列のデータ入力　→　「列挿入」のマクロ実行　としてみてください。

Sub 列挿入()
Dim i As Long, j As Long, astRow As Long, str As String, c As Range, wS As Worksheet
Set wS = Worksheets(1)
0: str = InputBox("挿入した列番号を数値で入力" & vbCrLf & "（例）B列を挿入した場合は 2 と入力")
If Len(str) = 0 Then
If MsgBox("処理を中止しますか？", vbYesNo) = vbYes Then
Exit Sub
Else
GoTo 0
End If
Else
j = Val(str)
Application.ScreenUpdating = False
With Worksheets(Worksheets.Count)
.Columns(j).Insert
.Range("B1").Resize(, 2).Merge
.Cells(2, j) = wS.Cells(1, j)
For i = 3 To .Cells(Rows.Count, "A").End(xlUp).Row
Set c = wS.Range("A:A").Find(what:=.Cells(i, "A"), LookIn:=xlValues, lookat:=xlWhole)
.Cells(i, j) = wS.Cells(c.Row, j)
Next i
.Range("A1").CurrentRegion.Borders.LineStyle = xlContinuous
End With
Application.ScreenUpdating = True
End If
End Sub

※　あくまで最初のマクロを実行したのちの列挿入です。
列挿入後「Sample1」のマクロを実行してしまうとメチャクチャな表示になってしまいます。

※　列挿入後に各Sheetのデータ変更がある場合は
根本的に考え直す必要があると思います。m(_ _)m

お礼

コードまでご指南頂きとても感謝しております。今回はとても勉強になりました。ありがとうございました！！！！

回答No.4

kihonkana

どういう風に使うのかよくわからないんですが...
最初からAa列を追加しておいて、Aa列を使わない場合は空白のまま、使う場合のみ文字列を記入するようにすれば1つのプログラムでいけるんではないでしょうか？
プログラムを例示できればいいんですけど、VBAは少しかじっただけなので...

回答No.2

tom04

No.1です。

＞表３のA1項目が列数が３から４に増えた場合など期待する結果とならないようです。
これは当方の勘違いでした。確かに前回のコードではダメですね。

＞また以下のような表４が増えた場合はどうでしょうか？
もう一度コードをいじくってみました。
表4まであるというコトは表4はSheet4となり、表示したいSheetはSheet5とします。
すなわち表の数よりも一つ多いSheet数が存在して、最終Sheetに表示するようにしています。

今回は各項目が何行あっても対応できるようにしてみました。

Sub Sample1()
Dim i As Long, k As Long, lastRow As Long, lastCol As Long, myMax As Long
Dim c As Range, r As Range, wS As Worksheet
Application.ScreenUpdating = False
With Worksheets(Worksheets.Count)
.Cells.Clear
.Cells.UnMerge
Worksheets(1).Range("A1").Copy .Range("B1").Resize(2)
For k = 1 To Worksheets.Count - 1
Set wS = Worksheets(k)
lastCol = wS.Cells(1, Columns.Count).End(xlToLeft).Column
wS.Cells(1, "B").Resize(, lastCol - 1).Copy .Cells(2, Columns.Count).End(xlToLeft).Offset(, 1)
With .Cells(1, Columns.Count).End(xlToLeft).Offset(, 1).Resize(, lastCol - 1)
.Merge
.Value = k
End With
For i = 2 To wS.Cells(Rows.Count, "A").End(xlUp).Row
Set c = .Range("A:A").Find(what:=wS.Cells(i, "A"), LookIn:=xlValues, lookat:=xlWhole)
If c Is Nothing Then
.Cells(Rows.Count, "A").End(xlUp).Offset(1) = wS.Cells(i, "A")
End If
Next i
Next k
For i = 2 To .Cells(Rows.Count, "A").End(xlUp).Row
For k = 1 To Worksheets.Count - 1
Set wS = Worksheets(k)
Set c = wS.Range("A:A").Find(what:=.Cells(i, "A"), LookIn:=xlValues, lookat:=xlWhole)
If Not c Is Nothing Then
myMax = WorksheetFunction.Max(myMax, WorksheetFunction.CountIf(wS.Range("A:A"), .Cells(i, "A")))
End If
Next k
.Cells(Rows.Count, "B").End(xlUp).Offset(1).Resize(myMax) = .Cells(i, "A")
myMax = 0
Next i
For i = 2 To .Cells(Rows.Count, "A").End(xlUp).Row
For k = 1 To Worksheets.Count - 1
Set wS = Worksheets(k)
lastRow = wS.Cells(Rows.Count, "A").End(xlUp).Row
lastCol = wS.Cells(1, Columns.Count).End(xlToLeft).Column
wS.Range("A1").AutoFilter field:=1, Criteria1:=.Cells(i, "A")
Set c = .Range("B:B").Find(what:=.Cells(i, "A"), LookIn:=xlValues, lookat:=xlWhole)
Set r = .Rows(2).Find(what:=wS.Range("B1"), LookIn:=xlValues, lookat:=xlWhole)
If wS.Cells(Rows.Count, "A").End(xlUp).Row > 1 Then
Range(wS.Cells(2, "B"), wS.Cells(lastRow, lastCol)). _
SpecialCells(xlCellTypeVisible).Copy .Cells(c.Row, r.Column)
End If
wS.AutoFilterMode = False
Next k
Next i
.Range("A:A").Delete
With .Range("A1").CurrentRegion
.Borders.LineStyle = xlContinuous
.HorizontalAlignment = xlCenter
End With
Application.DisplayAlerts = False
.Range("A1:A2").Merge
Application.DisplayAlerts = True
End With
Application.ScreenUpdating = True
End Sub

※　各コードの説明を入れれば良いのでしょうが、文字制限数を超えそうなので
とりあえずはコードのみの投稿です。

今度はお望み通りになれば良いのですが・・・m(_ _)m

補足

表の増減にも対応頂き、まさに期待通りの結果を出力しました。とても勉強になり感謝しております。
真に恐縮ですが参考までに、以下のように表１（マスタ）に結果出力に常に表示するAa列が追加された場合もご教授願えませんでしょうか？
何卒よろしくお願い致します。

表１（マスタ）
A列、B列、C列、D列、E列
A1 ,B1 ,C1 ,D1 ,E1
A2 ,B2 ,C2 ,D2 ,E2
↓
表１
A列、Aa列、B列、C列、D列、E列
A1 ,Aa1, B1 ,C1 ,D1 ,E1
A2 ,Aa2 ,B2 ,C2, D2 ,E2

表2、3は変わらず。

結果
A列、Aa列、B列、C列、D列、E列、F列、G列、H列
A1 ,Aa1, B1 ,C1 ,D1 ,E1 ,F1 ,G1 ,H1
A1 ,Aa1 ,F11 ,G11 ,H11
A1 ,Aa1 ,H111
A2 ,Aa2 ,B2 ,C2, D2 , E2 ,F2, G2 ,H2
A2 ,Aa2 ,F22, G22 ,H22
A2 ,Aa2 ,F222, G222 ,H222

※その他の表にはAa列は無し

回答No.1

tom04

こんばんは！
無理やりやってみました。

↓の画像のように表1はSheet1・表2はSheet2・表3はSheet3にあり、Sheet4にまとめるとします。

標準モジュールに↓のコードをコピー＆ペーストしてみてください。

Sub Sample1()
Dim i As Long, k As Long, cnt As Long, lastRow As Long, lastCol As Long
Dim c As Range, r As Range, wS As Worksheet
Application.ScreenUpdating = False
With Worksheets(4)
.Cells.Clear
.Cells.UnMerge
Worksheets(1).Range("A1").Copy .Range("B1").Resize(2)
For k = 1 To 3
Set wS = Worksheets(k)
lastCol = wS.Cells(1, Columns.Count).End(xlToLeft).Column
wS.Cells(1, "B").Resize(, lastCol - 1).Copy .Cells(2, Columns.Count).End(xlToLeft).Offset(, 1)
With .Cells(1, Columns.Count).End(xlToLeft).Offset(, 1).Resize(, lastCol - 1)
.Merge
.Value = k
End With
For i = 2 To wS.Cells(Rows.Count, "A").End(xlUp).Row
Set c = .Range("A:A").Find(what:=wS.Cells(i, "A"), LookIn:=xlValues, lookat:=xlWhole)
If c Is Nothing Then
.Cells(Rows.Count, "A").End(xlUp).Offset(1) = wS.Cells(i, "A")
End If
Next i
Next k
For i = 2 To .Cells(Rows.Count, "A").End(xlUp).Row
For k = 1 To 3
Set wS = Worksheets(k)
Set c = wS.Range("A:A").Find(what:=.Cells(i, "A"), LookIn:=xlValues, lookat:=xlWhole)
If Not c Is Nothing Then
cnt = cnt + 1
End If
Next k
.Cells(Rows.Count, "B").End(xlUp).Offset(1).Resize(cnt) = .Cells(i, "A")
cnt = 0
Next i
For i = 2 To .Cells(Rows.Count, "A").End(xlUp).Row
For k = 1 To 3
Set wS = Worksheets(k)
lastRow = wS.Cells(Rows.Count, "A").End(xlUp).Row
lastCol = wS.Cells(1, Columns.Count).End(xlToLeft).Column
wS.Range("A1").AutoFilter field:=1, Criteria1:=.Cells(i, "A")
Set c = .Range("B:B").Find(what:=.Cells(i, "A"), LookIn:=xlValues, lookat:=xlWhole)
Set r = .Rows(2).Find(what:=wS.Range("B1"), LookIn:=xlValues, lookat:=xlWhole)
If wS.Cells(Rows.Count, "A").End(xlUp).Row > 1 Then
Range(wS.Cells(2, "B"), wS.Cells(lastRow, lastCol)). _
SpecialCells(xlCellTypeVisible).Copy .Cells(c.Row, r.Column)
End If
wS.AutoFilterMode = False
Next k
Next i
.Range("A:A").Delete
With .Range("A1").CurrentRegion
.Borders.LineStyle = xlContinuous
.HorizontalAlignment = xlCenter
End With
Application.DisplayAlerts = False
.Range("A1:A2").Merge
Application.DisplayAlerts = True
End With
Application.ScreenUpdating = True
End Sub

※　無駄なループを繰り返しているかもしれません。
じっくり考えればもっと簡単になるかもしれませんが、
とりあえずはこの程度で・・・m(_ _)m

補足

素晴らしいコードありがとうございます。早速動かして期待どおりの結果となることを確認致しました。ただし、例えば、以下のように表３のA1項目が列数が３から４に増えた場合など期待する結果とならないようです。

A列、H列
A1 ,H1
A1 ,H11
A1 ,H111
A1 ,H1111
A2 ,H2
A2 ,H22
A2 ,H222

また以下のような表４が増えた場合はどうでしょうか？
A列、I列、J列
A1 ,I1 ,J1
A1 ,I11 ,J11
A2 ,I2 ,J2
A2 ,I22 ,J22
A2 ,I222 ,J222
A2 ,I2222 ,J2222
ステップ実行で流れを追ってみましたが
i,k,cntなどの変数の役割がつかめ切れず上記の応用に対応出来ない状況です。厚かましいお願いなのですがこちらもぜひご教授頂けないでしょうか？よろしくお願い致します。