ここから本文です

VBA 別シートを検索し、値があった場合値をコピーする方法について お世話にな...

y52********さん

2018/9/1211:56:12

VBA 別シートを検索し、値があった場合値をコピーする方法について

お世話になっております。
「シート1」と「シート2」があります。シート1のC列に入力があると(複数行)、同じ値を「シート2」のD列に探しにいき、も

し、一致する値があれば、その行の一個右端のセルに、シート1のD列にある値をコピーさせたいのですが(検索した値の隣)、マクロ初心者なのでソース頂けたら幸いです。
※シート1のC列で上から下まで値が入っているだけ、上の処理を行いたいです。

よろしくお願いいたします。

補足イメージとしましては
→sheet1でマクロを走らせ、c列の値が、sheet2のD列にあるか検索する。
→sheet2のD列で同じ値があればそのセル行を抽出する。
→sheet1のÇ列の検索もとの右隣の値を抽出し先程ヒットしたsheet2の行の右橋のセルにコピーする
→sheet1のC列のデータが無くなるまで、上記を繰り返す
→sheet2では結果的に適合した行にの右側に値が追加されていく。
よろしくお願いします。

閲覧数:
751
回答数:
3

違反報告

ベストアンサーに選ばれた回答

ask********さん

2018/9/1305:26:35

こんな感じでできるかと思います。

【Sheet1のC列に品番を入力】したら、Sheet2のD列から入力値を検索します。
ヒットした場合は、(入力したセルの右隣の値)を転記します。
転記先の列は、(該当行の右端列+1)です。

●●●●●●●●●●●●●●
Sheet1で、既に入力してある品番に対して処理を行う場合は、
検索対象のセル範囲を選択して、同じ場所にコピペしてください。
ctrl+c
ctrl+v
●●●●●●●●●●●●●●

添付図(左)Sheet1
添付図(右)Sheet2

Sheet1の黄色いセルが入力セルです。
Sheet2の黄色いセルが、入力後に転記したセルです。

セルの着色は解説用です。実際には着色しません。


Sheet1のシートモジュール
Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)
Dim Rng As Range, R As Range

If Intersect(Target, Range("c:c")) Is Nothing Then Exit Sub
'(1)[セル内容を変更したセル範囲]とC列に共通範囲が存在しない
If Intersect(Target, Range("c:c")).Address <> Target.Address Then Exit Sub
'(2)[セル内容を変更したセル範囲]に、C列以外のセルを含んでいる

'--(1)(2)共に満たさない場合は下記処理を行う

For Each R In Target
'Sheet1で、セル内容を変更したセル範囲すべてが対象
With Worksheets("Sheet2")

If R.Value <> "" Then
'空白以外は検索を行う

Set Rng = .Range("d:d").Find(R.Value, _
LookIn:=xlValues, LookAt:=xlWhole)
If Not Rng Is Nothing Then
.Cells(Rng.Row, Columns.Count).End(xlToLeft).Offset(, 1).Value = _
R.Offset(, 1).Value
'ヒットした場合は、Sheet2の該当行の(右端列+1)に、検索値の行のD列の値を転記
End If
End If
End With
Next R

End Sub

こんな感じでできるかと思います。...

返信を取り消しますが
よろしいですか?

  • 取り消す
  • キャンセル

質問した人からのコメント

2018/9/13 19:35:32

ご回答いただきありがとうごさいました。他の方々にも感謝しておりますが、画像付きでわかりやすく、とても為になりました。
ありがとうございました。

ベストアンサー以外の回答

1〜2件/2件中

並び替え:回答日時の
新しい順
|古い順

プロフィール画像

カテゴリマスター

aka********さん

2018/9/1213:26:47

シートモジュールです。

Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Column = 3 Then
検索値 = Target.Value
値 = Cells(Target.Row, "D")
Set Rng = Sheet2.Columns(4).Cells.Find(検索値)
If Not Rng Is Nothing Then
R = Rng.Row
C = Sheet2.Cells(R, Columns.Count).End(xlToLeft).Column + 1
Sheet2.Cells(R, C) = 値
End If
End If
End Sub

返信を取り消しますが
よろしいですか?

  • 取り消す
  • キャンセル

hel********さん

2018/9/1215:52:32

>※シート1のC列で上から下まで値が入っているだけ、上の処理を行いたいです。

Sheet1にボタンを作成して、そのボタンに下のコードを登録してください。

Sub Sample()
Dim ws1 As Worksheet, ws2 As Worksheet
Dim FC As Range, i As Long
Set ws1 = Sheets("Sheet1")
Set ws2 = Sheets("Sheet2")
With ws1
For i = 1 To .Range("C" & Rows.Count).End(xlUp).Row
Set FC = ws2.Range("D:D").Find(What:=.Range("C" & i).Value, LookAt:=xlWhole)
If Not FC Is Nothing Then
ws2.Range("D" & FC.Row).Offset(, 1) = .Range("C" & i).Offset(, 1)
End If
Set FC = Nothing
Next i
End With
End Sub

返信を取り消しますが
よろしいですか?

  • 取り消す
  • キャンセル

あわせて知りたい

この質問につけられたタグ

みんなで作る知恵袋 悩みや疑問、なんでも気軽にきいちゃおう!

Q&Aをキーワードで検索:

Yahoo! JAPANは、回答に記載された内容の信ぴょう性、正確性を保証しておりません。
お客様自身の責任と判断で、ご利用ください。
本文はここまでです このページの先頭へ

「追加する」ボタンを押してください。

閉じる

※知恵コレクションに追加された質問は選択されたID/ニックネームのMy知恵袋で確認できます。

不適切な投稿でないことを報告しました。

閉じる