項目に対する備品をリンク

質問

エクセルマクロでsheet1とsheet2をリンクする方法を教えて下さい。

sheet1には全体のデータが入っています。
sheet2には部屋名は入れてあるのですが、備品と数量は空欄です。

sheet1のC4セルより下方向には部屋名が入力してあります、キッチン。そしてG４セルより下方向には備品名が入力してあります、電子レンジ。そしてO４セルより下方向には数量が入力してあります、２。
以降下に続いていきます。1390まで下に続いてます。

その情報をsheet2のB1セルにキッチンと入力してありますので、B１セルに入力してある部屋名の情報を読み取ってsheet1のC４セルがキッチンとなっている項目が30ほどあったならその備品名と数量をsheet2のF4に備品をG4に数量と横方向に6項目まで、備品、数量とリンクさせ、その後は2行目、3行目とリンクさせます。

sheet1

　　　　　部屋名　　　　　　　　　　備品　　　　　　　数量　　　　
　　　　　　C4　　　　　　　　　　　　G4　　　　　　　　０４

　　　　　キッチン　　　　　　　　　電子レンジ　　　　　　２
　　　　　キッチン　　　　　　　　　　冷蔵庫　　　　　　　 １
　　　　　　：　　　　　　　　　　　　　 ：　　　　　　　　　 ：
　　　　　玄関　　　　　　　　　　スリッパ　　　　　　　１０

sheet2

　　部屋名　　　備品　　数量　　　備品　　　数量　　　備品　数量　備品　数量　備品　数量
　　　B1　　　　　F4　　　　G4　　　　H4　　　　　I4　　　　J4　　　K4　　L4　　M4　　N4　　O4
キッチン　　電子レンジ　　２　　　冷蔵庫　　　１　　　　‥　　　１　　‥　　　２　　　‥　　２
　　　　　　　　ポット　　　　 1　（6個以上あれば2行目へ）

　玄関　　　　スリッパ　　　１０　　　　　　　

5個までしか入力できなかったのですが、実際は横方向に備品、数量は6個いきます。B1の部屋名をと同じ名前の備品をsheet1より探してきます。キッチンとなっているものを上記のように飛んでくるようにしたいです。
どういう方法でやれますか？

回答No.1

x0000x

マクロで処理するなら以下のコードを"Sheet2"のコードとして貼り付けしてください。

Sheet2のB列に入力した部屋名をSheet1から検索して表示します。
（既に入力済みの場合は、部屋名の入力されているセルでF2,Enterと
続けて押下することで、再入力した事として処理できます。）

コードの張り付け方法は、
(1)Sheet2のシート見出しでマウス右クリック。
(2)表示されたメニューの「コードの表示」をクリック
(3)以下のコードを空白部分に貼り付けます。

Private Sub Worksheet_Change(ByVal Target As Range)
'Sheet2以外は処理しない。
'選択セルが複数存在する場合は処理しない
'B列の入力変更以外は処理しない
'入力文字列が空の場合は処理しない
If ActiveSheet.Name <> "Sheet2" Then Exit Sub
If Target.Count <> 1 Then Exit Sub
If Target.Column <> 2 Then Exit Sub
If Target.Value = "" Then Exit Sub

Dim st As Worksheet
Dim stR1 As Long
Dim stR2 As Long
Dim stC2 As Integer
Dim heya As String
Dim cnt As Integer

'Sheet1を取得
heya = Target.Value '入力した部屋名
Set st = Sheets("Sheet1")
stR2 = Target.row 'Sheet2の入力セルの行位置を初期設定
stC2 = 6 'Sheet2の最初の表示列番号を初期設定
cnt = 0 '表示個数を初期化

For stR1 = 4 To 1390
If st.Cells(stR1, 3) = heya Then
'入力した部屋名を見つけた
If stC2 > 17 Then
stC2 = 6 '格納列を先頭に戻す
stR2 = stR2 + 1 '格納行を1行UP
End If

ActiveSheet.Cells(stR2, stC2) = st.Cells(stR1, 7) '備品
ActiveSheet.Cells(stR2, stC2 + 1) = st.Cells(stR1, 15) '数量
'次の格納列位置を設定
stC2 = stC2 + 2
'表示個数を加算
cnt = cnt + 1
End If
Next

If cnt = 0 Then
MsgBox "[ " + heya + " ] は検索できませんでした。"
'入力した部屋名に再度位置付ける
ActiveSheet.Cells(stR2, 2).Select
Else
'次の部屋名入力セルに位置付ける
ActiveSheet.Cells(stR2 + 1, 2).Select
End If
End Sub

お礼

ありがとうございます。

コードを実行しようとするとエラー　end subが必要ですとでます。
どう対処したらよいですか？

補足

すみません。
sheet1の名前は1階～4階でsheet2の名前は部屋別リストです