VBAを使って検索したセルを別のシートにコピーする

質問

こんにちは。
業務でエクセルを使用して差し込み文書を印刷しています。
量が多いのでＶＢＡを使って簡単に作業したいです。

まず、以下のようなシートがあります。
＜Sheet１＞差込文書
＜Sheet２＞
（Ａ）　　（Ｂ）　　　　（Ｃ）　　　　　（Ｄ）　（Ｅ）　　（Ｆ）
番号｜会社名｜支店名｜役職名｜氏名｜会社、支店名、役職名、氏名

次のような作業をさせたいです。
１．<sheet２＞のＡ列と同じ番号が＜sheet1＞の（Ｌ１）にあるかどうか検索する。
２．もし、一致するセルがあれば、<sheet2>の該当番号の行のＦ列を<sheet１＞の（Ｂ５）にすべて（書式ごと）コピーする。

以上です。
VLOOKUP関数でしましたが、すべてをコピーする事ができなかったので、ＶＢＡでコピーしたいです。
Ｆ列は、個人名だけの方、支店がない会社などがあるため、バランス良く配置しているセルです。
よろしくお願いします。

回答No.3

watabe007 · ベストアンサー

Worksheet_Changeイベントを使うと
＜sheet1＞のＬ１セルに入力すると
＜sheet２＞のＡ列に同じ番号を検索に行きます。
あれば＜sheet２＞の検索行のＦ列をコピーして＜sheet1＞のＢ５セルに貼り付けます。

以下を＜sheet1＞のシートモジュールに貼り付けてお試し下さい。
Private Sub Worksheet_Change(ByVal Target As Range)
　　Dim myR As Variant
　　With Target
　　　　If .Count > 1 Then Exit Sub
　　　　If .Value = "" Then Exit Sub
　　　　If .Address <> "$L$1" Then Exit Sub
　　　　myR = Application.Match(.Value, Sheets("Sheet2").Columns(1), 0)
　　　　If IsError(myR) Then
　　　　　　'見つからなかった場合、Ｂ５セルをクリア
　　　　　　Range("B5").Clear
　　　　　　Exit Sub
　　　　End If
　　　　Sheets("Sheet2").Cells(myR, "F").Copy Range("B5")
　　End With
End Sub

お礼

お礼が遅くなりました。ありがとうございます。vbaがドシロウトなものでシートに貼付をして実行ボタンをクリックしてました。そうすると、マクロ名を聞いてきて、マクロ名を入力して実行すると「コンパイルエラー」がでてしまい、「？？」な状態でした。
何もしなくていいことに気づき、今現在、うまくできてます。
これだと、数字を変えただけで変わってくれるのですごく便利になりました。ありがとうございます。

回答No.2

watabe007

標準モジュールに貼り付けてお試し下さい。
Sub Test()
　　Dim myR As Variant

　　myR = Application.Match(Sheets("Sheet1").Range("L1").Value, Sheets("Sheet2").Columns(1), 0)
　　If IsError(myR) Then
　　　　MsgBox Sheets("Sheet1").Range("L1").Value & " は、見つかりません。"
　　　　Exit Sub
　　End If
　　Sheets("Sheet2").Cells(myR, "F").Copy Sheets("Sheet1").Range("B5")
End Sub

補足

お礼が遅くなりました。ありがとうございます。
初歩的な質問かもしれませんが、差込文書が違う文面をいくつかつくりたので＜Sheet１＞の箇所を”平成24年(2)”に試しにしてみました。
すると「実行時エラー’９’インデックスが有効範囲にありません」とでます。
シート名は変更するとだめなのでしょうか？

回答No.1

tom04

こんにちは！
一例です。

画面左下のSheet1のSheet見出し上で右クリック　→　コードの表示　→　VBE画面に
↓のコードをコピー＆ペーストしてマクロを実行してみてください。
（Alt＋F8キー　→　マクロ　→　マクロ実行です）

Sub sest() 'この行から
Dim k As Long
Dim ws As Worksheet
Set ws = Worksheets("Sheet2")
If WorksheetFunction.CountIf(ws.Columns(1), Range("L1")) Then
k = WorksheetFunction.Match(Range("L1"), ws.Columns(1), False)
ws.Range("F" & k).Copy Destination:=Range("B5")
Else
MsgBox "該当データがありません。"
End If
End Sub 'この行まで

※　Sheet1にコマンドボタンを配置しておけばもっと簡単かもしれませんね。

参考になりますかね？m(_ _)m

お礼

ありがとうございます。
したいことがちゃんとできるようになってました。
自分でそれなりに調べてたのですが、なかなかうまくいかなかったのでとても助かりました。