完全一致したら複数のセルを順に代入するマクロは？

質問

エクセルのSheet1のA列にある文字列と、Sheet2にあるA列にある文字列と完全一致したら、前者のセルの右右右隣セル（一致したセルから数えて４番目のセル）から３番目までのセルに、後者のセルの右隣セル（一致したセルから数えて２番目のセル）から３番目までの文字列を順に代入するマクロをお教えください。つまり代入開始セルをSheet1のD列にしたいのです。（実は任意の列からにしたのですが…）。単純にvlookup関数を使えばいいのですが、ＶＢＡで行いたいのです。

一致したセルの右隣のセルから順に代入するマクロは以下で解決済みです。以下のマクロを編集して実行したいのですが、どこをいじったらよいかわかりません。

なお、代入したいセルを右の任意のセルまで引き延ばしたい場合、以下のコード任意Loop Until Coln1 = 4の右辺の数字を変更すればよいことまではわかっています。どうぞ、よろしくお願い申し上げます。

----------------

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

回答No.2

mu2011 · ベストアンサー

>Coln1 = 1
　⇒シート１の列番号だからＤ列開始とすると初期値は３（後で＋１する）

ループ処理は面倒なので検索対象が重複しない事が前提にFind関数を使用した一例です。
Offsetは０相対、Resizeは１相対となりますのでご注意ください。

Sub sample()
転送先 = "D"　'転送先の列番号
転送元 = 1 '転送元の列番号（相対）
サイズ = 2 '転送サイズ

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, "A"), _
LookAt:=xlWhole, MatchCase:=True, MatchByte:=True)
If Not pos Is Nothing Then
st1.Cells(i, 転送先).Resize(1, サイズ).Value = _
pos.Offset(0, 転送元).Resize(1, サイズ).Value
End If
Next
End Sub

お礼

ご回答ありがとうございます。Find関数を使用するとシンプルですね。これでもうまくいきました。転送元のサイズを変更したい場合や、転送先の開始列を変更したい場合も、上３行の右辺を変えればよいだけなのでわかりやすいです。ありがとうございます。

補足

すみません。このFind関数を基にしたマクロにさらに、ブック間の転送をするにはどうしたらよいでしょうか。本当にしたいことは実はブック間なのです。ブックＡのシート１に、ブックＢにあるシート２のデータを同様に転送したいのです。よろしくお願い申し上げます。

回答No.5

keithin

要するにＢ，Ｃ，Ｄ列のデータを，Ｄ，Ｅ，Ｆ列に転送できれば良いんですね。
アナタの説明はとても判りにくいです。「目に見える姿」を具体的に示してください。

作成例：book1，book2の両方を開いた状態から，book2.xlsのシート２のＢＣＤ列の値を，book1.xlsのシート１のＤＥＦ列に転送する

sub macro1r1()
　dim r as long
　r = workbooks("Book1.xls").worksheets("Sheet1").range("A65536").end(xlup).row

　with workbooks("Book1.xls").worksheets("Sheet1").range("D1:F" & r)
　　.formula = "=VLOOKUP(A1,'[Book2.xls]Sheet2'!A:D,COLUMN(B2),FALSE)"
　　.value = .value
　　on error resume next
　　.specialcells(xlcelltypeconstants, xlerrors).clearcontents
　end with
end sub

お礼

早々の回答をありがとうございます。拡張子をとって実行しました。そしたらBook2を選べました。ただ、転送がうまくいきませんでした。すみません。

回答No.4

KURUMITO

示されたマクロの変更でしたら
Coln1=1をColn1=3に変更(2か所）
Loop Until Coln1=4をLoop Unti Coln1=6に変更(1か所）すればよいでしょう。

お礼

ありがとうございます。これでうまくいきました。大変助かります。

回答No.3

mu2011

NO2です。
初期値の列番号の他にループ条件も変更が必要です。
　Loop Until Coln1 = 4　⇒　Loop Until Coln1 = 3 + 3

回答No.1

keithin

ところでご質問に書かれている「４番目から３番目のセルに」というのは，書き間違いじゃなくてワザワザそういう意図で書いてるんですね？
非常に判りにくいですけど。アナタが正しく書いているという前提で回答します。

今のマクロのシート１のＡ列×シート２のＡ列（×無駄に４回）の総当たりも必ずしも悪いことばかりじゃありませんが，やっぱりあまりに非効率なので，ざっとこんな具合にします。

sub macro1()
　dim r as long
　r = worksheets("Sheet1").range("A65536").end(xlup).row

’検索
　worksheets("Sheet1").range("D1:D" & r).formula = "=VLOOKUP(A1,Sheet2!A:C,2,FALSE)"
　worksheets("Sheet1").range("C1:C" & r).formula = "=VLOOKUP(A1,Sheet2!A:C,3,FALSE)"

’処理
　with worksheets("Sheet1").range("C1:D" & r)
　.value = .value
　on error resume next
　.specialcells(xlcelltypeconstants, xlerrors).clearcontents
　end with
end sub

補足

早々のご回答ありがとうございます。私の質問文があいまいですみません。Sheet1のA列から数えて「４番目から３番目のセルに」というのは、左に戻るのではなくて、「４番目から右に順に３番目のセルに」という意味です。つまりSheet1のD列からF列に代入したいのです。
この場合、いただいたコードのどこを変更したらよいでしょうか？改めてご教授いただけませんか。よろしくお願い申し上げます。