Excel VBA質問箱 IV

当質問箱は、有志のボランティア精神のおかげで成り立っています。
問題が解決したら、必ずお礼をしましょうね。
本サイトの基本方針をまとめました。こちら をご一読ください。

投稿種別の選択が必要です。ご注意ください。
迷惑投稿防止のため、URLの入力を制限しています。ご了承ください。


4773 / 76732 ←次へ | 前へ→

【77575】マッチしたら指定範囲を別シートへコピー
質問  soul-taker  - 15/10/26(月) 16:25 -

引用なし
パスワード
   初めて投稿致します。
よろしくお願いします。

・sheetA
 「A5:I20」に文字データが入っています。
 (途中に空白列有り。最終行は月度によって変動。)

・sheetB
 「A5:A30」に文字データが入っています。
 (途中に空白列有り。最終行は月度によって変動。)

・sheetAの「A5」列と同じ値のものがsheetBの「A5」列内に
 あった場合、その同じ値の行の「C列からI列」をsheetA→
 sheetBにコピーする。
 (sheetAもsheetBも都度、最終行が変わるので、文字デー
  タの範囲が変わる。)
・できれば、途中で並べ替えの作業等や作業列の作成はしたく
 ない。

 <例>
  【sheetA】
       A  B  C D E F G H I
    5  0001    ○ あ     ○ か
    6  0006    ○ い
    7
    8  0035        ○ ○ ○ き
    9  0018    ○ う         ○
    ・
    ・
    19  0099        ○   ○
    20  0102    ○ え
 

  【sheetB】
    sheetBは、最初はA列のみにデータがあり、C〜
    I列は空白の状態。
    5行目、6行目、9行目が、それぞれsheetAの5行目
    6行目、8行目と同じなので、それぞれのsheetAの
    A列でマッチしたC列〜I列をsheetBのC列〜I
    列にコピーして、下記の結果としたい。

       A  B  C D E F G H I
    5  0001    ○ あ     ○ か
    6  0006    ○ い
    7  0042
    8
    9  0035        ○ ○ ○ き
    10  0051
    ・
    ・
    30  0099        ○   ○


これを下記のように記述したところ、うまくいかずに悩んでい
ます。

Dim r1 As Range, r2 As Range, c As Range
Dim m As Variant

Sheets(A).Select

With Worksheets(A)
  Set r2 = .Range("A5", .Cells(.Rows.Count, 1).End(xlUp))
End With
With Worksheets(B)
  Set r1 = .Range("A5", .Cells(.Rows.Count, 1).End(xlUp))
End With
 
For Each c In r1
  m = Application.Match(c.Value2, r2, 0)
  If IsNumeric(m) Then
    r2.Item(m, 3).Resize(, 7).Copy c.Item(1, 3)
  End If
Next

別のところで、うまくいっていた事例を移植したのですが、
(実のところ、中身がきちんと理解できていないので)どこ
がマズイのかが見つけられませんでした。

どなたか、ご助言いただけますと助かります。
何とぞ、よろしくお願い致します。

1 hits

【77575】マッチしたら指定範囲を別シートへコピー soul-taker 15/10/26(月) 16:25 質問[未読]
【77576】Re:マッチしたら指定範囲を別シートへコピー β 15/10/26(月) 19:16 発言[未読]
【77581】Re:マッチしたら指定範囲を別シートへコピー soul-taker 15/10/27(火) 8:23 発言[未読]
【77582】Re:マッチしたら指定範囲を別シートへコピー β 15/10/27(火) 8:52 発言[未読]
【77583】Re:マッチしたら指定範囲を別シートへコピー soul-taker 15/10/27(火) 14:53 お礼[未読]

4773 / 76732 ←次へ | 前へ→
ページ:  ┃  記事番号:
2610219
(SS)C-BOARD v3.8 is Free