VBAで2つのデータを横に結合できますか？

質問

Sheet1には以下のデータが入力されています。

NO　TIMES　SCORE
1　　1　　20
1　　2　　30
1　　3　　25
2　　1　　50
2　　2　　40
2　　3　　45
3　　1　　70
3　　2　　75
4　　3　　3

いっぽうsheet2には以下のデータが入力されています。

NO　　NAME　　SEX　　AGE
1　　Ａさん　　男　　31
2　　Ｂさん　　女　　27
3　　Ｃさん　　女　　33
4　　Ｄさん　　男　　26

この２つのデータをNOをキーとして横に結合したいのですが
VBAでこのような結合操作はできるものでしょうか？

NO NAME SEX AGE TIMES SCORE
1 Ａさん 男 31 1 20
1 Ａさん 男 31 2 30
1 Ａさん 男 31 3 25
2 Ｂさん 女 27 1 50
2 Ｂさん 女 27 2 40
2 Ｂさん 女 27 3 45
3 Ｃさん 女 33 1 70
3 Ｃさん 女 33 2 75
4 Ｄさん 男 26 3 3

if文を使ってNOが1ならNAMEがAさん、SEXが男・・・という
条件文をかけばできないこともありませんが、
実際のデータではNOが450もありますので
非効率と考えています。
もしご存知でしたら教えていただけませんか。
よろしくお願いいたします。

回答No.3

keirika · ベストアンサー

シート１の横にシート２の情報を貼り付ける方法です。
質問に提示された列の並びと異なりますが、結合と言う意味では
要件を満たしていると思います。

シート２は見出しを含め451行あると仮定します。

Sub Sample()

Dim SH1 As Range
Dim SH2 As Range
Dim i As Long

Set SH1 = Sheets("Sheet1").Range("a1").CurrentRegion
Set SH2 = Sheets("Sheet2").Range("a1:d451")

For i = 2 To SH1.Rows.Count
SH1.Cells(i, 4) = Application.VLookup(SH1.Cells(i, 1), SH2, 2, 0)
SH1.Cells(i, 5) = Application.VLookup(SH1.Cells(i, 1), SH2, 3, 0)
SH1.Cells(i, 6) = Application.VLookup(SH1.Cells(i, 1), SH2, 4, 0)
Next i

Set SH1 = Nothing
Set SH2 = Nothing

End Sub

以上です。

お礼

ありがとうございます。
コンパクトで分かりやすいですね。
SETというものを知らなかったので、大変勉強になりました。
ありがとうございます。
自分でもコードを１からなぞって勉強させていただきます。

ところでコード中にa1:d451ってありますが、この451を
SH1.Rows.COUNTに置き換えることってできるのでしょうか？

回答No.5

keirika

＃３です。

＞ところでコード中にa1:d451ってありますが、この451を
＞SH1.Rows.COUNTに置き換えることってできるのでしょうか？

シート１とシート２では行数が異なると思いますので、出来ません。
汎用性と言う意味ではRange("a1:d451")の代わりにRange("a1").CurrentRegion
とした方が良いかもしれません。

回答No.4

mitarashi

VBAを持ち出さずとも、VLOOKUPで十分ではないかと思いましたが、VBAで式を、動的な対象範囲に対して生成するのはどうやるのかなと、気になったのでやってみました。#3と考え方は似ているかもしれません。ご参考まで．．．とは言い難いですが。
'Sheet1,Sheet2のデータを照合して、Sheet3にまとめる
Sub test()
Dim destRange As Range
Dim i As Long
Dim master As Range
Dim fieldNames As Range

Sheets("Sheet1").Cells.Copy Sheets("Sheet3").Range("a1")
Set master = Sheets("Sheet2").Range("a1").CurrentRegion
Set fieldNames = master.Rows(1)
Set master = master.Offset(1, 0).Resize(master.Rows.Count - 1, master.Columns.Count)
Set destRange = Sheets("Sheet3").Range("a1").CurrentRegion
Set destRange = destRange.Offset(1, 0).Resize(destRange.Rows.Count - 1, destRange.Columns.Count)
For i = 2 To 4
destRange.Columns(i).EntireColumn.Insert Shift:=xlToRight
destRange.Columns(i).FormulaR1C1 = "=VLOOKUP(RC1,Sheet2!" & master.Address(True, True, xlR1C1) & "," & Format(i, "0") & ",false)"
Next i
fieldNames.Copy Sheets("Sheet3").Range("a1")
End Sub
関数入力を自動記録すると、R1C1形式で記述される事を知りました。

お礼

ありがとうございます。
今まではvlookupでやっていたのですが、ここひと月前から
VBAを勉強中でして、実際に今までやってきた業務を
VBAでできるかチャレンジしていたのでした。

いやいやみなさん、スラスラとお書きになられるようで
すばらしいです。
いただいたコードを勉強します！

回答No.2

n-jun

ANo.1です。

＞,　n　As　Long
変数ｎは使っていないので削除して下さい。

回答No.1

n-jun

Sheet２にはNoの重複がないものとして、結果をSheet３に書き出します。

Sub　test()
　Dim　Dic　As　Object
　Dim　i　As　Long,　j　As　Long
　Dim　m　As　Long,　n　As　Long
　Dim　v,　w,　x

　Set　Dic　=　CreateObject("Scripting.Dictionary")

　With　Worksheets("Sheet2")
　　　　　　v　=　.Range(.Range("A2"),　.Range("A"　&　Rows.Count).End(xlUp).Resize(,　4)).Value
　End　With

　ReDim　x(1　To　6,　1　To　1):　m　=　1

　For　i　=　1　To　UBound(v,　1)
　　　　　Dic.Add　v(i,　1),　Array(v(i,　2),　v(i,　3),　v(i,　4))
　Next

　With　Worksheets("Sheet1")
　　　　　　w　=　.Range(.Range("A2"),　.Range("A"　&　Rows.Count).End(xlUp).Resize(,　3)).Value
　　　　　　For　j　=　1　To　UBound(w,　1)
　　　　　　　　　　If　Dic.exists(w(j,　1))　Then
　　　　　　　　　　　　　x(1,　m)　=　w(j,　1):　x(2,　m)　=　Dic(w(j,　1))(0)
　　　　　　　　　　　　　x(3,　m)　=　Dic(w(j,　1))(1):　x(4,　m)　=　Dic(w(j,　1))(2)
　　　　　　　　　　　　　x(5,　m)　=　w(j,　2):　x(6,　m)　=　w(j,　3)
　　　　　　　　　　　　　m　=　m　+　1
　　　　　　　　　　　　　ReDim　Preserve　x(1　To　6,　1　To　m)
　　　　　　　　　　End　If
　　　　　　Next
　End　With

　With　Worksheets("Sheet3")
　　　　　　.Range("A1:F1").Value　=　Array("NO",　"NAME",　"SEX",　"AGE",　"TIMES",　"SCORE")
　　　　　　.Range("A2").Resize(m　-　1,　6).Value　=　Application.Transpose(x)
　End　With

　Set　Dic　=　Nothing
　Erase　v,　w,　x
End　Sub
ご参考になれば。

お礼

ありがとうございます。
非常にエレガントなコードですね。
コードを見せていただきましたが、知らない構文がいろいろと
あるので、いい勉強材料をいただいたと感謝しております。
やはり本よりも人が書いたコードのほうが勉強になりますね。

私もあなたのようにスラスラとコードが書けるように
がんばっていきたいです。
今後ともよろしくお願いいたします。