• ベストアンサー
  • すぐに回答を!

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

  • 質問No.7147576
  • 閲覧数903
  • ありがとう数4
  • 回答数5

お礼率 69% (50/72)

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

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

なお、代入したいセルを右の任意のセルまで引き延ばしたい場合、以下のコード任意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
  • ベストアンサー

ベストアンサー率 38% (1910/4994)

>Coln1 = 1
 ⇒シート1の列番号だからD列開始とすると初期値は3(後で+1する)

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

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
補足コメント
paraseke

お礼率 69% (50/72)

すみません。このFind関数を基にしたマクロにさらに、ブック間の転送をするにはどうしたらよいでしょうか。本当にしたいことは実はブック間なのです。ブックAのシート1に、ブックBにあるシート2のデータを同様に転送したいのです。よろしくお願い申し上げます。
投稿日時:2011/11/23 06:44
お礼コメント
paraseke

お礼率 69% (50/72)

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

その他の回答 (全4件)

  • 回答No.5

ベストアンサー率 66% (5277/7938)

要するにB,C,D列のデータを,D,E,F列に転送できれば良いんですね。
アナタの説明はとても判りにくいです。「目に見える姿」を具体的に示してください。


作成例:book1,book2の両方を開いた状態から,book2.xlsのシート2のBCD列の値を,book1.xlsのシート1のDEF列に転送する

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
お礼コメント
paraseke

お礼率 69% (50/72)

早々の回答をありがとうございます。拡張子をとって実行しました。そしたらBook2を選べました。ただ、転送がうまくいきませんでした。すみません。
投稿日時:2011/11/24 05:36
  • 回答No.4

ベストアンサー率 42% (1835/4283)

示されたマクロの変更でしたら
Coln1=1をColn1=3に変更(2か所)
Loop Until Coln1=4をLoop Unti Coln1=6に変更(1か所)すればよいでしょう。
お礼コメント
paraseke

お礼率 69% (50/72)

ありがとうございます。これでうまくいきました。大変助かります。
投稿日時:2011/11/24 05:29
  • 回答No.3

ベストアンサー率 38% (1910/4994)

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

ベストアンサー率 66% (5277/7938)

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

今のマクロのシート1のA列×シート2のA列(×無駄に4回)の総当たりも必ずしも悪いことばかりじゃありませんが,やっぱりあまりに非効率なので,ざっとこんな具合にします。


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
補足コメント
paraseke

お礼率 69% (50/72)

早々のご回答ありがとうございます。私の質問文があいまいですみません。Sheet1のA列から数えて「4番目から3番目のセルに」というのは、左に戻るのではなくて、「4番目から右に順に3番目のセルに」という意味です。つまりSheet1のD列からF列に代入したいのです。
この場合、いただいたコードのどこを変更したらよいでしょうか?改めてご教授いただけませんか。よろしくお願い申し上げます。
投稿日時:2011/11/23 04:19
関連するQ&A

その他の関連するQ&Aをキーワードで探す

ページ先頭へ