「教えて!ピックアップ」リリース!

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

A 回答 (2件)

一例です。



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

この回答への補足

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

補足日時:2011/11/18 04:46
    • good
    • 0
この回答へのお礼

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

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

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

この大切なことが書いてない。m方見つからないこともありえるのか。こういう所へ意識が行く、センスがVBAをやるときは大切なのだ。
(1)VBAでもVLOOKUP関数は使える。しかし探索範囲の最初(一番上行)に出現する最初のもの1つしか捜せない。
だから複数を見つける場合は、見つかった行の次の行からの探索範囲に改めて(縮めて)、再度VLOOKUPを使えば第2・第3以下が捜せる。
(2)Findメソッドでも出来る。
しかし、
・見つからない場合の処理
・2つ目以降の探索
が初心者には難しい。
(3)全セルをIF文で判別を繰返す方法が一番判りやすい。初心者はこに方法から初めては。
(4)作業シートなどで探索列でソートして置いて、2分探索法などででやると、件数が膨大な場合は速いかもしてない。
ーーー
>後者のセルの右隣から3番目までの文字列を順に代入するマクロをお教えください
・コピー貼り付け法 貼り付け先の基点セルを指定して貼り付け
・同行の各セルに代入法 こちらはセルの数だけステートメントを並べる。これは出来るだろう。
質問は後者の指定になっているが、前者でも間に合うのでは。
ーーー
検索の操作をして、マクロの記録も取って勉強した形跡が無い。
初心者はそれぐらいやってみるべきだ。
ーー
下記は
・Sheet1のA列にはダブって文字列が出ない(1つしかない)
・必ず見つかる
という前提のプログラムだが。
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列からD列まで
sh2.Cells(i, j) = WorksheetFunction.VLookup(x, sh1.Range("A1:D100"), j, False)
Next j
Next i
End Sub
この質問は丸投げになっているが、むしろ上記コードのSet sh1 = Worksheets("Sheet1")
などを使えるようになることのほうが肝心な気がする。
    • good
    • 0
この回答へのお礼

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

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

お探しのQ&Aが見つからない時は、教えて!gooで質問しましょう!

このQ&Aを見た人はこんなQ&Aも見ています


このQ&Aを見た人がよく見るQ&A

人気Q&Aランキング