• ベストアンサー

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

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

質問者が選んだベストアンサー

  • ベストアンサー
  • mu2011
  • ベストアンサー率38% (1910/4994)
回答No.1

一例です。 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

paraseke
質問者

お礼

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

paraseke
質問者

補足

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

すると、全ての回答が全文表示されます。

その他の回答 (1)

  • imogasi
  • ベストアンサー率27% (4737/17069)
回答No.2

完全一致などと難しい言葉を使う割りに、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") などを使えるようになることのほうが肝心な気がする。

paraseke
質問者

お礼

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

すると、全ての回答が全文表示されます。

関連するQ&A

専門家に質問してみよう