エクセル 複数シートを連動させる

質問

EXCELで下記のリンク(画像が添付できなかったのでお手数おかけします)画像のような文化祭の準備の物品貸し出し表を作成しているのですが、知識がないため行き詰まってしまっていて、作成期限が迫っているので皆様のお力をお借りできたらと考えております。
今回は見やすいように2つのブックを使用していますが、左がシート1で右がシート2だと考えてください。
まず現時点で完成している機能としては、
・VBAによるユーザーフォームでシート1の情報を簡易入力
・返却期限を一週間後に設定し、その期限が来たら視覚的に色を付け、期限切れの欄に自動で「◎」がつくように設定
※今は日付上色がついていませんが、実際は期限の前日、当日、翌日からの7日間 の間は返却期限のセルがそれぞれ色付けされるように書式設定してあります。
・期限内に返却された場合は、返却済み欄に ◯ を入力することによって期限切れ欄にはマークされないように設定
大まかにはこのような感じなのですが、ここからが本題です。
「期限切れになったところを抽出してわかりやすくしておいてくれ。」
という指示があり、期限切れになるとシート2に上から順に「NO.」から「担当者名」までが抽出されるようにしたいです。
そして、抽出されたデータがある行はセルが色付けされるようにしたいです。
また、シート2の一番右「返却確認」に◯がついた場合、シート2のその行の色付けを解除し、シート1の対応している行の期限後返却確認 の欄に◯がつくようにしたいです。
VBAが必要でしたら使用しても構いません。
自分の知識に見合わないような複雑な作業をすることになってしまい、説明もごちゃごちゃしてしまい申し訳ないのですが、教えていただければ嬉しく思います。
画像リンク；https://gyazo.com/0f79b7c20f5c7a0d7b7069c61b202517

回答No.2

nishi6 · ベストアンサー

こんなものかなということで作ってみました。
画像リンクを参考に作っています。マクロ内に絶対番地がかなり入っています。
分かりやすく書いたつもりなのでなんとかなればと思います。最大行数は「2000行」にしています。

色指定の「xlThemeColorAccent6」などはネットで調べたり、マクロを記録して好きな色に変更してください。

質問を読んでそのまま作ると、Sheet1の「期限後返却確認」に印をつけても、再度抽出すると期限切れとして抽出されます。
期限切れも消したい場合は、「 '.Offset(rw1, 9) = "" '// 期限切れをクリア」のコメントを外してください。

Sheet1からの抽出はボタンから指示できますが、「返却確認」に対応した処理はセルの変更を契機に動くようにしています。

Excel2010で確認しました。
＜Sheet1＞にCommandButtonを1つ作り、
＜Sheet1＞のコードウィンドウに以下を貼り付けます

Private Sub CommandButton1_Click()
　　Dim rw1 As Long '// 行番号(Sheet1)
　　Dim rw2 As Long '// 行番号(Sheet2)
　　Dim col As Long '// 列番号
　　Dim ws2 As Worksheet '// sheet2
　　Set ws2 = Worksheets("Sheet2")

　　With Worksheets("Sheet2").Range("B4:J2000")
　　　　.ClearContents '// テキトーに消す
　　　　.Interior.Pattern = xlNone
　　End With

　　rw1 = 0: rw2 = 0
　　With Range("B4")
　　　　'// 全件調べる
　　　　While .Offset(rw1, 0) <> ""
　　　　　　If .Offset(rw1, 9) <> "" Then '// 期限切れに入力があれば
　　　　　　　　For col = 0 To 7 '// Sheet2にコピーする
　　　　　　　　　　ws2.Range("B4").Offset(rw2, col) = .Offset(rw1, col)
　　　　　　　　Next

　　　　　　　　With ws2.Range("B4") '// 色を付ける(好きな色にしてください)
　　　　　　　　　　ws2.Range(.Offset(rw2, 0), .Offset(rw2, 7)).Interior.ThemeColor = xlThemeColorAccent6 '// 色指定
　　　　　　　　End With

　　　　　　　　rw2 = rw2 + 1
　　　　　　End If
　　　　　　rw1 = rw1 + 1
　　　　Wend
　　End With
End Sub

＜Sheet2＞のコードウィンドウに以下を貼り付けます
'// 返却確認に「○」が入力された時の処理
Private Sub Worksheet_Change(ByVal Target As Range)
　　Dim num As Integer '// No.
　　Dim rw1 As Long '// 行番号(Sheet1)

　　'// 1つのセルへの入力で、J列への入力でデータがあれば処理をする
　　If Target.Count = 1 Then
　　　　If Not (Application.Intersect(Range("J4:J2000"), Target) Is Nothing) Then
　　　　　　With Target
　　　　　　　　If .Offset(0, -8) <> "" And Target = "○" Then
　　　　　　　　　　Range(.Offset(0, -8), .Offset(0, -1)).Interior.Pattern = xlNone
　　　　　　　　　　'// 期限後返却確認
　　　　　　　　　　num = .Offset(0, -8)
　　　　　　　　　　With Worksheets("Sheet1").Range("B4")
　　　　　　　　　　　　While .Offset(rw1, 0) <> ""
　　　　　　　　　　　　　　If .Offset(rw1, 0) = num Then
　　　　　　　　　　　　　　　　.Offset(rw1, 10) = "○" '// 期限後返却確認に○
　　　　　　　　　　　　　　　　'.Offset(rw1, 9) = "" '// 期限切れをクリア　今はコメント行
　　　　　　　　　　　　　　End If
　　　　　　　　　　　　　　rw1 = rw1 + 1
　　　　　　　　　　　　Wend
　　　　　　　　　　End With
　　　　　　　　End If
　　　　　　End With
　　　　End If
　　End If
End Sub

お礼

回答ありがとうございます！
参考にさせていただきます

回答No.6

imogasi

質問に余分な、回答に関係ない、個人的事情などを書かないこと。
データ例を少数挙げること。
ーー
条件で行データを抜き出す１つの方法を解説する。
自称imogasi方式を、下記でやってみる。
作業列をSheet1のG列を使うが、（１）VBAや（２）INDEX－Match]-SMALL方式（３）数式配列を誓う方法より、理解しやすいだろうと思う。
例データ　Sheet1　シートのデータのコピペだが、何とかわかるだろう。
貸出日 品名 　数　借主 　返却日
2019/7/12 マット 2 田中 2019/7/13
2019/7/13 ベース 4 木村
2019/7/14 ボール 20 田中淳 2018/7/14
2019/7/15 ミット 3 大野
2019/7/16 グラブ 5 小田
2019/7/16 ラインマーカ 1 鈴木
2019/7/13 ジョロ 4 戸田
G1見出し＝「該当件」と文字入力。多少違っても何でもよい。
G2の式　=IF(E2<>"","",IF(A2+7<=$F$1,MAX($G$1:G1)+1,""))
（$の付けてある位置と、＄の有無は正確に）
式の意味は、現在日と貸し出し日＋７の大小を比較判定しただけ。該当件数に上行から連番を振っているだけ。
エクセルでは、日付は、日々の順の、整数的な数であることを知ること。
＋７は返却日条件を７日後と（小生が）単純化にしたところから来る。
G列でG3せるから、データのある最下行まで式複写。
＝＝＝
Sheet2に行って
第1行に見出し作成　=TEXT(Sheet1!F1,"yy/mm/dd") &"現在　未返却物"
Sheet1のF1セルに現在日入力してあるとする。2019/7/22 する
第2行に見出し　貸出日 品名 数 借主 返却日　コピペ
Sheet２のA3セルに=INDEX(Sheet1!$A$1:$E$100,MATCH(ROW()-2,Sheet1!$G$1:$G$100,0),COLUMN())を入れる。
右方向にE列まで式を複写。
A3:E3を範囲指定して、E3での＋ハンドルを下方向に引っ張る。
未返却の該当が３件なので、第５行目で複写を止める。
結果　Sheet2　A1:E5
19/07/22現在　未返却物
貸出日 品名 数 借主 返却日
2019/7/13 ベース 4 木村 0
2019/7/15 ミット 3 大野 0
2019/7/13 ジョロ 4 戸田 0

お礼

回答ありがとうございます！
教えて頂いた通りやってみます！

補足

個人情報は気をつけるようにします
ありがとうございます

回答No.5

bunjii

>期限切れになるとシート2に上から順に「NO.」から「担当者名」までが抽出されるようにしたいです。
1つのブックにSheet1とSheet2を作成し、Sheet1を「物品貸出簿」とします。
Sheet2は期限切れの貸し出し明細を組み込み関数で抽出します。
Sheet2のB4セルに次の数式を設定し、右と下へコピーします。
=IF(COUNTIFS(Sheet1!$H$4:$H$20,"<"&TODAY(),Sheet1!$J$4:$J$20,"<>"&"◯")<ROWS(B$4:B4),"",INDEX(Sheet1!$A$1:$I$20,SMALL(INDEX((Sheet1!$H$4:$H$20<TODAY())*(Sheet1!$J$4:$J$20="")*ROW($B$4:$B$20)+(Sheet1!$J$4:$J$20="◯")*21+(Sheet1!$H$4:$H$20>=TODAY())*21,0),ROWS(B$4:B4)),COLUMN()))
計算範囲の4行から20行は「物品貸出簿」の行数に応じて変更してください。
Sheet2のC列とH列は日付のシリアル値が返されますので表示形式を「m月d日」に設定します。
Sheet2のJ列へキーボードから入力された値をSheet1のL列へ反映させるにはL4セルへ次の数式を設定して下へ必要数コピーします。
=IFERROR(VLOOKUP(B4,Sheet2!$B$4:$J$20,9,FALSE)&"","")
Sheet1のL列へ反映されたマークをSheet2の抽出に反映して消し込みをすることは数式の参照がループになるため関数では対応できません。
Sheet2のJ列に「◯」を入力した結果でセルの塗りつぶしを解除するには条件付き書式で対応すれば良いでしょう。

添付画像はExcel 2013で検証した結果です。

お礼

回答ありがとうございます
教えて頂いた通りやってみます

回答No.4

bunjii

>今回は見やすいように2つのブックを使用していますが、左がシート1で右がシート2だと考えてください。
2つのブックですか？
1つのブックに2枚以上のSheetを作成できますので1つのブックで良いと思います。

>期限切れになるとシート2に上から順に「NO.」から「担当者名」までが抽出されるようにしたいです。
Excelの組み込み関数だけでも処理可能です。
期限切れのみを抽出する理由は何ですか？
未返却の全てを抽出するのであれば返却時のチェックリストとして利用できますが未返却で期限切れのみを抽出しても無駄になりませんか？
当方ではExcel 2013で提示の画像内容で目的に合う数式を検証してみます。
結果は後日回答します。

>VBAが必要でしたら使用しても構いません。
他の回答への補足ではVBAの知識も無いようですから仕様変更が発生したときまた此処へ質問しなければなりません。
論理も分からずに丸写しで流用するのは如何なものでしょう。

お礼

回答ありがとうございます
確かに仕様変更された場合は対処しきれなくなってしまいますね…
参考にさせていただきます

回答No.3

bunjii

画像リンクに何も表示されません。
サンプルデータをテキストデータ（空白またはカンマ区切り）で提示してください。

回答No.1

kon555

>>VBAによるユーザーフォームでシート1の情報を簡易入力
ここまで作るスキルがあるなら、同様にVBAで期限切れを抽出するといいと思います。
『期限切れの欄に自動で「◎」がつく』という部分を利用して、K列を目印に対象行を抽出。シート2に内容をコピーさせればいいでしょう。
ただこの方式だと、返却された後にシート2からも削除しなければならないので、いっそシート2は開くたびに抽出・表示させるだけと割り切ったほうが手間がないと思います。

ただわざわざシートを分ける必要があるのか？　については再度確認した方がいいですね。同一シートでいいなら、期限切れ欄でフィルタさせるだけで済むので圧倒的にシンプルです。

補足

実はこちらのVBAのコードも、質問させて頂いて書いたコードなので、ほんとに知識がないんです…
ただ、高校の生徒会の中では1番Excelが出来てしまうので頼まれてしまったという感じなんです…(￣▽￣;)
ただ確かにおっしゃる通り、同一シートでフィルタすればいいだけの話ですね…！
単純にその発想出てきませんでした（笑）
それも方法の一つとして検討します！
僕以外にもそこまでパソコンが得意じゃない人もいるので、それが一番楽かもしれませんね