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

質問

エクセルマクロで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.3

x0000x

先頭行の"Sub 部屋別マクロ()"に対応する"END SUB”なしが原因です。

"Sub 部屋別マクロ()"の行を削除してください。

ご提示したマクロは、Sheet２のB列に"キッチン"等の部屋名を入力することで
"Worksheet_Change"イベントが発生し、実行されます。
このイベント名（Worksheet_Change）は変更できません。

（つまり部屋名1件入力ごとに備品、数量を6列＊ｎ行で表示するものです。）

Excelの数式に設定してご利用することはできません。
また、他のマクロから呼び出す場合には、引数の"Target"をRangeオブジェクトで
渡す必要があります。(場合によっては、マクロ記述場所も変更になります）

質問者様の現状の運用とかけ離れた回答である可能性も認識しておりますが、
このマクロを利用することで問題解決の一助になればと思い回答しています。

お礼

ありがとうございました。
実際自分がよくわかっていない現状で、なんとかやってみたのですが、なかなか運用するまでに至りません。

実行できるマクロの数は、パターンは数える程度しかできません。
少し複雑になってくるともう出来なくなってしまうのです。
なんとか自分で思うように組めるようになりたいのですが、
お礼が遅くなりました、それまで色々な角度から挑戦してみたのですが、
やはり上手くいきませんでした。今後もこういった作業があるので、
完成させたいと思います。

回答No.2

x0000x

貼り付けしたコードの最後の行に「End Sub」が記述されていますか？

最後の行まで正しく貼り付けできていないのではないでしょうか？

または、長い行で自動的に折り返しが発生している可能性もあります。

ActiveSheet.Cells(stR2, stC2) = st.Cells(stR1, 7) '備
品
　　　　↓
ActiveSheet.Cells(stR2, stC2) = st.Cells(stR1, 7) '備品

上記の様に1行になるように調整してみてください。

（ちなみに"'"から始まる部分はコメントです。
　自動改行により"品"から始まる行はエラーになります。
　→この場合は「SUBまたは、Functionが定義されていません。」
になります。）

ご確認ください。

お礼

先ほどの回答の一行にとどめることは、知りませんでした。
参考になりましたが、やはりエラーがででしまいます。

補足

Sub 部屋別マクロ()
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

このように貼り付けましたが、同じエラーがでます。

回答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の名前は部屋別リストです