完全一致したら代入するマクロを教えてください

エクセルのSheet1のa列にある文字列と、Sheet2にあるa列にある文字列と完全一致したら、前者のセルの右隣に後者のセルの右隣の文字列を代入するマクロをお教えください。単純にvlookup関数を使えばいいのですが、ＶＢＡで行いたいのです。よろしくお願い申し上げます。

No.2 回答者： imogasi 回答日時： 2011/11/17 09:56

完全一致などと難しい言葉を使う割りに、Ｓｈｅｅｔ１には探索語は１回しか出現しないのだろうね。

この大切なことが書いてない。ｍ方見つからないこともありえるのか。こういう所へ意識が行く、センスがＶＢＡをやるときは大切なのだ。
（１）VBＡでもＶＬＯＯＫＵＰ関数は使える。しかし探索範囲の最初（一番上行）に出現する最初のもの１つしか捜せない。
だから複数を見つける場合は、見つかった行の次の行からの探索範囲に改めて（縮めて）、再度ＶＬＯＯＫＵＰを使えば第２・第３以下が捜せる。
（２）Ｆｉｎｄメソッドでも出来る。
しかし、
・見つからない場合の処理
・２つ目以降の探索
が初心者には難しい。
（３）全セルをＩＦ文で判別を繰返す方法が一番判りやすい。初心者はこに方法から初めては。
（４）作業シートなどで探索列でソートして置いて、２分探索法などででやると、件数が膨大な場合は速いかもしてない。
ーーー
＞後者のセルの右隣から３番目までの文字列を順に代入するマクロをお教えください
・コピー貼り付け法　貼り付け先の基点セルを指定して貼り付け
・同行の各セルに代入法　こちらはセルの数だけステートメントを並べる。これは出来るだろう。
質問は後者の指定になっているが、前者でも間に合うのでは。
ーーー
検索の操作をして、マクロの記録も取って勉強した形跡が無い。
初心者はそれぐらいやってみるべきだ。
ーー
下記は
・Ｓｈｅｅｔ１のＡ列にはダブって文字列が出ない（１つしかない）
・必ず見つかる
という前提のプログラムだが。
Sub test01()
Dim sh1, sh2 As Worksheet
Set sh1 = Worksheets("Sheet1")
Set sh2 = Worksheets("Sheet2")
d = sh2.Range("A65536").End(xlUp).Row
MsgBox d
For i = 2 To d
x = sh2.Cells(i, "A")
For j = 2 To 4 'B列からＤ列まで
sh2.Cells(i, j) = WorksheetFunction.VLookup(x, sh1.Range("A1:D100"), j, False)
Next j
Next i
End Sub
この質問は丸投げになっているが、むしろ上記コードのSet sh1 = Worksheets("Sheet1")
などを使えるようになることのほうが肝心な気がする。

この回答へのお礼

早々の回答をありがとうございました。私の操作が悪いのかうまくいきませんでした。すみません。

お礼日時：2011/11/18 12:04

No.1 ベストアンサー 回答者： mu2011 回答日時： 2011/11/17 09:44

一例です。

Sub sample()
Set st1 = Worksheets("sheet1")
Set st2 = Worksheets("sheet2")
For i = 1 To st1.Cells(Rows.Count, 1).End(xlUp).Row
Set pos = st2.Range("a:a").Find(st1.Cells(i, 1), _
LookAt:=xlWhole, MatchCase:=True, MatchByte:=True)
If Not pos Is Nothing Then
st1.Cells(i, 1).Offset(o, 1) = pos.Offset(0, 1)
End If
Next
End Sub

この回答への補足

どうもありがとうございます。やりたいことができました。もう一つお教えください。私の説明不足で、この場合は一致したセルの右隣の一つのセルしか代入できませんが、右隣から３つまでのセルなど、複数のセルを代入する場合はこのコードから、さらにどうしたらよいでしょうか。よろしくお願い申し上げます。

補足日時：2011/11/18 04:46

この回答へのお礼

右に貼り付けたいセルを複数にするやり方は以下で解決しました。シンプルで完璧なマクロをありがとうございました。

Sub 試験()

Dim Row1 As Integer
Dim Coln1 As Integer
Dim Row2 As Integer
Dim Coln2 As Integer
Set WS1 = Worksheets("Sheet1")
Set WS2 = Worksheets("Sheet2")
Coln1 = 1
Coln2 = 1
For Row1 = 1 To WS1.Cells(Rows.Count, 1).End(xlUp).Row
For Row2 = 1 To WS2.Cells(Rows.Count, 1).End(xlUp).Row
If WS2.Cells(Row2, 1) = WS1.Cells(Row1, 1) Then
Do
Coln1 = Coln1 + 1
Coln2 = Coln2 + 1
WS1.Cells(Row1, Coln1) = WS2.Cells(Row2, Coln2)
Loop Until Coln1 = 4
Coln1 = 1
Coln2 = 1
End If
Next Row2
Next Row1

End Sub

お礼日時：2011/11/18 12:03