VBA 比較してリンク

初めまして。VBA初心者です。
まずはこちらを見て下さい。

　 Sheet1 　　　　　　　　　　 　　　　Sheet2　　　　　　　　
　 　 A 　　　 B 　　　C 　　D 　　　　　　　A　　　　 B 　　　C 　　D
1 大区分 中区分 名称 　　　　　　20 大区分 中区分 名称
2　　A　　　　 a　　　 あ　　 1　　　　21　　A　　　　 a　　　あ　　　1
3　　　　　　　　　　　　い　　2　　　　22　　　　　　　　　　　 い　　　2
4　　　　　　　　　　　　う　　 3　　　　23　　　　　　　　　　　 う　　　3
5　　　　　　　　　　　　え　　4　　　　24　　　　　　　　　　　 お　　　5
6　　　　　　　　　　　　お　　5　　　　25　　　　　　　 b　　　 あ　　　1→6
7　　　　　　　 b　　　　あ　　6　　　　26　　　　　　　　 　　　い　　　2→7
8　　　　　　　　　　　　い　　7　　　　27　　　　　　　　　　　 う　　　 3→8
9　　　　　　　　　　　　う　　 8　　　　28　　　　　　　　　　　 お　　　5→10
10　　　　　　　　　　　 え　　9　　　　29　　B　　　　 a　　　 か　　　11
11　　　　　　　　　　　 お　　10　　　30　　　　　　　　　　　　き　　　12
12　　B　　　　a　　　 か　　11　　 　31　　　　　　　　　　　 け　　　14
13　　　　　　　　　　　 き　　12　　　 32　　　　　　　　　　　 こ　　　 15
14　　　　　　　　　　　 く　　 13　　　 33　　　　　　　b　　　 か　　　 11→16
15　　　　　　　　　　　 け　　14　　　 34　　　　　　　　　　　 き　　　 12→17
16　　　　　　　　　　　 こ　　 15　　　 35　　　　　　　　　　　け　　　 14→19
17　　　　　　　b　　　 か　　 16　　　 36　　　　　　　　　　　こ　　　 15→20
18　　　　　　　　　　 　き　　 17
19　　　　　　　　　　　 く　　　18
20　　　　　　　　　　　 け　　 19
21　　　　　　　　　　　 こ　　 20

元々関数を使用していたのですが、数があまりに多くなってきたため、VBAで処理できればと初めて作ってみましたが、途中で行き詰った為ご教授お願いします。
Sheet1,2にそれぞれ表があり、Sheet1が元となります。（行は1000行以上になることもあります。）
それで、Sheet2の名称をSheet1の名称と比べ同じ場合、Sheet1のD列をSheet2のD列にリンクさせたいのです。
一応、色々見ながら下記のように組んでみたのですが、矢印の左側のようになってしまいます。
これを、右側のような結果にしたいのですが、なんとなく間違ってる箇所は分かるものの、どのようにしていいか分かりません。
これをどのようにしたらよろしいでしょうか？若しくは、他にやり方があれば教えて頂きたいです。
分かりづらい説明で申し訳ないですが、よろしくお願い致します。

sub test()
　Dim i As Integer,maxrow As Integer
　maxrow = Sheet2.Range("C" : Rows.Count).End(xlup).Row
　　　For i = 1 To maxrow - 19
　　　　　If Sheet1.Cells (1+i,3)=Sheet2.Cells(19+i,3) Then
　　　　　　　Sheet2.Cells(19+i,4)="=Sheet1" & Sheet1.Cells(1 + i,3).Offset(0,1).Address
　　　　　Else
　　　　　　　Sheet2.Cells(19+i,4)="=Sheet1" & Sheet1.Cells.Find(Sheet2.Cells(19+i,3))　_
　　　　　　　　　　　　　　　　　　　　　　　.Offset(0,1).Address
　　　　　End　if
　　　Next i
End sub

No.2 ベストアンサー 回答者： end-u 回答日時： 2012/10/20 21:53

ふむ。

失礼。
方針変更です。test1、test2は無かった事にしてください。
以下、■箇所のみ設定して後は相対関係で処理。

Sub test3()
　　Dim r(1 To 2) As Range　'起点セル｜Key列
　　Dim tmp　　　 As Range　'xlCellTypeBlanks用
　　Dim s　　　　 As String 'R1C1数式共通文字用
　　Dim i　　　　 As Long
　　Dim x　　　　 As Long　 '列指定用
　　Dim y　　　　 As Long　 '行指定用
　　Dim v　　　　　　　　　 'Application.Match用配列

　　'各シートのデータの起点セルを指定
　　Set r(1) = Excel.Range("Sheet1!A2")　'■
　　Set r(2) = Excel.Range("Sheet2!A21") '■

　　x = r(1).Column + 3
　　y = r(1).Row - 1
　　For i = 1 To 2
　　　　With Excel.Range(r(i), r(i).Range("C1").EntireColumn.Cells(Rows.Count).End(xlUp))
　　　　　　'空白セルだけを取得[ctrl]+[g]ジャンプ機能
　　　　　　Set tmp = .Columns("A:B").SpecialCells(xlCellTypeBlanks)
　　　　　　'直上の値をセット
　　　　　　tmp.FormulaR1C1 = "=R[-1]C"
　　　　　　'rにE列を再セット
　　　　　　Set r(i) = .Columns("E")
　　　　End With
　　　　'E列を作業エリアとして A列&B列&C列 のキーを作る
　　　　r(i).FormulaR1C1 = "=RC[-4]&RC[-3]&RC[-2]"
　　　　r(i).Value = r(i).Value
　　　　'空白セル式クリア
　　　　tmp.ClearContents
　　Next
　　'Match関数で行位置取得
　　v = Application.Match(r(2), r(1), 0)
　　'作業エリアクリア
　　r(1).ClearContents
　　r(2).ClearContents
　　s = "='" & r(1).Worksheet.Name & "'!R"
　　'Loopして数式セット
　　With r(2).Offset(, -1).Cells
　　　　For i = 1 To UBound(v)
　　　　　　If IsNumeric(v(i, 1)) Then
　　　　　　　　.Item(i).FormulaR1C1 = s & v(i, 1) + y & "C" & x
　　　　　　End If
　　　　Next
　　End With
End Sub

この回答へのお礼

お返事遅くなりました。今回のは思っていた通りのものでした。
本当にありがとうございました。すごく助かりました。
また、質問させて頂くことがあると思いますが、よろしくお願い致します。
（というより、同じ仕事の系列でもう出ていますが…＾＾；）

お礼日時：2012/10/21 18:42

No.1 回答者： end-u 回答日時： 2012/10/19 23:26

効率を考えれば、セルのデータ範囲を一旦、配列に取得し、

Loop処理で空白データの場合は直上のデータを見るようにし、
とにかくA列&B列&C列で、参照キーとなるデータを作る事です。
その後の照合については、MATCH関数を使っても良いし。

Sub test1()
　　Dim i As Long
　　Dim j As Long
　　Dim v, w, x, y, z, a, b

　　For i = 1 To 2
　　　　With Sheets("Sheet" & i)
　　　　　　With .Range("A1", .Cells(.Rows.Count, "C").End(xlUp))
　　　　　　　　v = .Columns("A:B").Value
　　　　　　　　w = .Columns("C").Value
　　　　　　End With
　　　　　　For j = 1 To UBound(v)
　　　　　　　　If Not IsEmpty(v(j, 1)) Then
　　　　　　　　　　a = v(j, 1)
　　　　　　　　End If
　　　　　　　　If Not IsEmpty(v(j, 2)) Then
　　　　　　　　　　b = v(j, 2)
　　　　　　　　End If
　　　　　　　　w(j, 1) = a & b & w(j, 1)
　　　　　　Next
　　　　End With
　　　　If i = 2 Then Exit For
　　　　x = w
　　Next
　　y = Application.Match(w, x, 0)
　　z = Application.Index(Sheets("Sheet1").Columns("D"), y)
　　Sheets("Sheet2").Range("D1").Resize(UBound(z)).Value = z
End Sub



作業エリアとして、E列が使えるのなら、数式を埋め込んで処理するほうが簡単です。

Sub test2()
　　Dim rng As Range
　　Dim rs　As Range
　　Dim x　 As Long
　　Dim i　 As Long

　　For i = 1 To 2
　　　　With Sheets("Sheet" & i)
　　　　　　'A2セルからC列最終データまでの範囲
　　　　　　Set rng = .Range("A1", .Cells(.Rows.Count, "C").End(xlUp).Offset(, -1))
　　　　End With
　　　　'後で使うからsheet1の最終行を覚えておく
　　　　If i = 1 Then x = rng.Rows.Count
　　　　'空白セルだけを取得[ctrl]+[g]ジャンプ機能
　　　　Set rs = rng.SpecialCells(xlCellTypeBlanks)
　　　　'直上の値をセット
　　　　rs.FormulaR1C1 = "=R[-1]C"
　　　　'E列を作業エリアとして A列&B列&C列 のキーを作る
　　　　With rng.Columns("E")
　　　　　　.Formula = "=A2&B2&C2"
　　　　　　.Value = .Value
　　　　End With
　　　　rs.ClearContents
　　Next
　　'Sheet2のD列にINDEX(..(MATCH..))関数で値を引っ張ってくる
　　With rng.Columns("D")
　　　　.Formula = "=index(sheet1!$D$1:$D$" & x & ",match(E2,sheet1!$E$1:$E$" & x & ",0))"
　　　　.Value = .Value
　　End With
End Sub

この回答へのお礼

ありがとうございます。早速検証させて頂きました。
一応Test1のほうは結果通りでしたが、Test2の方は1行ずれた（？）状態で表記されてるみたいでした。自分なりに考えてみましたが、どこを触っていいか分かりません。。。

後、説明の仕方が良くなかったですね。
Sheet2のD列には数値をそのまま入れるのではなく、=Sheet1!$D$2と入れる形にしたかったのです。
また、Sheet1とSheet2のそれぞれの開始行が違うのですが、Sheet2の上の方にエラー値が入ってしまいます。この場合でもなんとかなりますでしょうか？

度々のご質問で申し訳ないですが、よろしくお願い致します。

お礼日時：2012/10/20 02:30