特定の文字を条件に指定範囲のデータを貼り付けるVBA

いつもお世話になっております。
この度、下記の操作の自動化についてご教示をいただきたく質問させていただきました。

自動化したい処理内容は下記の添付画像を例にご説明いたします。
B列3行目より下記には各機材名が入力されており、黄色で示しております【VAIO】の文字に一致した場合、C1～F1(※オレンジ色で示しましたA・B・C・D(※ここには関数が入力されています。)のセルのデータを、離れた位置にございます【VAIO】が入力されている行の、H5、I5、J5、K5セルに貼り付けたい処理の内容となります。

どうぞよろしくお願いいたします。

No.2 ベストアンサー 回答者： めぐみん_ 回答日時： 2023/01/15 08:42

こんな感じでしょうか？

Sub megu()
Dim rr As Range
Dim rf As Range

Set rr = Range("B3", Cells(Rows.Count, "B").End(xlUp))
Set rf = rr.Find("VAIO", , xlValues, xlWhole)

If rf Is Nothing Then
MsgBox "検索値は見つかりませんでした"
Set rr = Nothing
Exit Sub
End If

Range("C1:F1").Copy
rf.Offset(, 6).PasteSpecial Paste:=xlPasteValues
Application.CutCopyMode = False

Set rr = Nothing
Set rf = Nothing

End Sub

後々は
＞Set rf = rr.Find("VAIO", , xlValues, xlWhole)
の "VAIO" の所を Range("B1").Value に変更してみて下さい。

この回答へのお礼

めぐみん様、VBAの構築ありがとうございます。

こちらで理想の処理ができました！
後々の変更箇所のご提示もありがとうございます。
大切に活用させていただきます。
ありがとうございました。

お礼日時：2023/01/19 09:14

No.3 回答者： fujillin 回答日時： 2023/01/15 10:28

こんにちは

＞自動化したい処理内容
「自動化」というのが、いちいちマクロを実行する操作をしなくても、入力をした際に自動的に実行されるという意味と解釈しました。

当該シートの「シートモジュール」に以下を記述ではいかがでしょうか。
（シートタブを右クリックし「コードの表示」を選択した際に表示されるエディタ画面に記述）

Private Sub Worksheet_Change(ByVal Target As Range)
Dim c
If Intersect(Target, Columns(2)) Is Nothing Then Exit Sub
Application.EnableEvents = False
For Each c In Intersect(Target, Columns(2)).Cells
If c.Value = "VAIO" Then
Cells(c.Row, 8).Resize(, 4).Value = Range("C1:F1").Value
End If
Next c
Application.EnableEvents = True
End Sub

※ コード設定した以降の操作に対して有効になります。
　（それ以前に入力済みのセルに対しては実行されません）

この回答へのお礼

fujillin様、回答に重ねVBAの構築ありがとうございます。

Changeイベントを組むことでこの様に自動化することができるのですね。
こちらも大切に活用させていただきます。
ありがとうございました。

お礼日時：2023/01/19 09:21

No.1 回答者： めぐみん_ 回答日時： 2023/01/15 06:37

＞【VAIO】の文字に一致した場合

Ｂ列の機材名が『何と』一致した場合なのでしょうか？
VAIO 固定ではないですよね？
例えばセルＢ１にその機材名が表示されるようになっている or 入力するようになっているとか？

この回答へのお礼

めぐみん様、いつもお世話になっております。
回答ありがとうございます。

私が将来イメージしております処理の内容と重なっており驚いております。
めぐみん様が仰る通り、例えば(機材管理表)という別シートを作成。
今後はこの表とB1セルに関数で機材名を反映させ、B1セルの機材名に一致した場合にデータを反映させたいと考えておりました。

ただ現状、別シートの完成が今しばらくかかるので今回はVAIOに一致した場合のみを処理内容としたいです。

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

お礼日時：2023/01/15 07:07