[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
『特定の文字・色がついたセルのシート名を表示させたい』（mammie）
駐車場の管理簿を作成しています。
例えば駐車番号が1～10あったとします。
駐車する人は、日々会社も人も違います。
会社ごとにシートを作り、カレンダー表にして駐車した日に駐車番号を入力していきます。
（仮に9/4現在で2番がa社、4番がb社使用中とします）
シート名【a社】
A B C D E ・・・
1 9/1 9/2 9/3 9/4 ・・・
2 佐藤 1 ・・・
3 田中 2 2 ・・・
シート名【b社】
A B C D E ・・・
1 9/1 9/2 9/3 9/4 ・・・
2 山田 3 3 ・・・
3 山本 4 ・・・
という感じです。
使用中の番号は、駐車番号を赤文字にし、使用が終了すると黒文字にします。
（上記で言うと1ち3は黒、2と4は赤文字になります）
これを、さらに別シートを作り、
1 2 3 4 5 6 7 8 9 10
a b
という感じに１枚のシートにまとめて、
今何番の駐車番号をどこの会社が使用しているかを管理したいのです。
（名前はわからなくていい）
全部のシートに対して、赤文字になっている特定の番号を認識させ、
さらにそのシート名を表示させたい・・・
そんなことが可能でしょうか・・・＞＜
＜ 使用 Excel：Excel2019、使用 OS：unknown ＞
1) 今、というのは「そのシートを閲覧している日付」という認識でいいですか？ (今日だったら9/7に入力されている番号だけ参照すればいいですか？) 2) シートはどんどん増える予定がありますか？ 3) 最終的にまとまる形式はその形でないとダメですか？ シート名 (会社名) が固定なのであれば、そこに何番を使用しているか並べるほうが簡単なので… 4) 仮に番号に対して会社を書く形式だとして、記入ミス等で別の会社に同じ番号があった場合はどのようにしたいですか？ （*） 2021/09/07(火) 09:54
駐車番号 開始日時 終了日時 会社名 担当者 1 2021/9/1 0:00 2021/9/7 0:00 a あ 1 2021/9/7 0:00 c お 3 2021/9/7 0:00 b い 5 2021/9/5 0:00 a う 9 2021/9/5 0:00 c え
こんな感じでデータをためて行けば、
数式で希望の表が得られると思います。
（とはいえ、数式を思いつきませんが。。。。＾＾；）
データの蓄積は、１件１行にしておくと後で集計等しやすいです。
ためたデータを見せたいように見せるのはその後の工夫です。
（まっつわん） 2021/09/07(火) 10:00
ありがとうございます。
1) 今、というのは「そのシートを閲覧している日付」という認識でいいですか？
(今日だったら9/7に入力されている番号だけ参照すればいいですか？)
はい。閲覧した日に把握できればいいです。
2) シートはどんどん増える予定がありますか？
増える可能性はあります。
3) 最終的にまとまる形式はその形でないとダメですか？ シート名 (会社名) が固定なのであれば、そこに何番を使用しているか並べるほうが簡単なので…
最終まとまる形式はまだ特に決めてないのですが、駐車番号の一覧表に使用中のとこがぱっとわかるようにしたいのです。
4) 仮に番号に対して会社を書く形式だとして、記入ミス等で別の会社に同じ番号があった場合はどのようにしたいですか？
エラー表示が出たら最適です。
やはりさすがにシートを分けてると色々難しいですよね・・・。
（mammie） 2021/09/07(火) 14:06
あと一つ聞き忘れてました。 各社のシートに入力されている日付はシリアル値ですか？
正直現状のレイアウトだとできなくはないけど面倒ですね。 シートの増減の際にまとめるシートをきちんとメンテナンスする前提なら TODAY関数で列との一致をとり、INDIRECT関数にシート名渡して参照するのがスタンダードですかね？ どうしても自動でシート名の取得をしたいならマクロ有効ブックにするしかないですね。
そういう意味でもまっつわんさん提示のレイアウトのように1つのシートに蓄積できるのが望ましいとは思います。 （*） 2021/09/07(火) 15:02
Dim sht As Worksheet, c As Range, r As Range, rr As Range
Sheets("まとめ").Rows("2:" & Rows.Count).ClearContents
For Each sht In ThisWorkbook.Worksheets
If sht.Name <> "まとめ" Then
Set r = Intersect(sht.Range("A1").CurrentRegion, sht.Range("A1").CurrentRegion.Offset(1, 1))
If Not r Is Nothing Then
If WorksheetFunction.CountA(r) Then
For Each c In r.SpecialCells(2)
Set rr = Sheets("まとめ").Rows(1).Find(c.Value, , , xlWhole)
If rr Is Nothing Then
Set rr = Sheets("まとめ").Cells(1, Columns.Count).End(xlToLeft).Offset(, 1)
rr.Value = c.Value
End If
If c.EntireColumn.Cells(1).Value = Date Then
If rr.Offset(1).Value <> "" Then
MsgBox rr.Value & "が重複しています" & vbLf & rr.Offset(1).Value & sht.Name
rr.Offset(1).Value = rr.Offset(1).Value & sht.Name
Else
rr.Offset(1).Value = sht.Name
End If
End If
Next c
End If
End If
End If
Next sht
End Sub
（mm） 2021/09/07(火) 15:14
INDIRECT関数ですか。なるほどです。
マクロだとできるんだろうなと思いながら、マクロがとてつもなく弱くて…。
色々ご丁寧にありがとうございます＞＜
ｍｍ 様
すごい！！！ありがとうございます！！！
（mammie） 2021/09/07(火) 15:30
＞マクロがとてつもなく弱くて…。
少しは出来るのなら、マクロで検討された方が良いかもです。
＞今何番の駐車番号をどこの会社が使用しているかを管理したいのです。
月極駐車場ではないのですね。ちょっとややこしい^^; （mammie）さんの希望どうりの表ではありませんが月極駐車場なら下記のサンプル表の形式がいいと思ったのですが。
|[A] |[B] |[C] |[D] |[E] |[F] |[G] |[H] |[I] |[J] |[K] |[L] |[M] |[N] |[O] |[P] |[Q] |[R] |[S] |[T] |[U] |[V] |[W] |[X] |[Y] |[Z] |[AA]|[AB]|[AC]|[AD]|[AE]|[AF]|[AG]
[1] | 2021| 9| | | | | | | | | | | | | | | | | | | | | | | | | | | | | | |
[2] | | |1日 |2日 |3日 |4日 |5日 |6日 |7日 |8日 |9日 |10日|11日|12日|13日|14日|15日|16日|17日|18日|19日|20日|21日|22日|23日|24日|25日|26日|27日|28日|29日|30日|1日
[3] |駐車番号|会社名|(水)|(木)|(金)|(土)|(日)|(月)|(火)|(水)|(木)|(金)|(土)|(日)|(月)|(火)|(水)|(木)|(金)|(土)|(日)|(月)|(火)|(水)|(木)|(金)|(土)|(日)|(月)|(火)|(水)|(木)|(金)
[4] |駐車場1 |A社 |○ |空 |○ |空 |空 |○ |○ | | | | | | | | | | | | | | | | | | | | | | | |
[5] |駐車場2 |B社 |○ |○ |○ |空 |空 |○ |○ | | | | | | | | | | | | | | | | | | | | | | | |
[6] |駐車場3 |C社 |○ |○ |○ |○ |空 |○ |空 | | | | | | | | | | | | | | | | | | | | | | | |
[7] |駐車場4 |C社 |○ |空 |空 |空 |○ |○ |○ | | | | | | | | | | | | | | | | | | | | | | | |
[8] |駐車場5 |A社 |○ |○ |○ |空 |空 |○ |○ | | | | | | | | | | | | | | | | | | | | | | | |
[9] |~ 略 ~ |B社 |○ |空 |○ |○ |○ |○ |空 | | | | | | | | | | | | | | | | | | | | | | | |
[10]|駐車場10|D社 |○ |○ |○ |○ |空 |空 |○ | | | | | | | | | | | | | | | | | | | | | | | |
＞会社ごとにシートを作り、カレンダー表にして駐車した日に駐車番号を入力していきます。
駐車番号と、会社を特定する番号を割り振るにて...二つの番号が混在する作りこみは複雑化でミスを招くのであまりお薦めできません。
＞使用中の番号は、駐車番号を赤文字にし、使用が終了すると黒文字にします。 （上記で言うと1ち3は黒、2と4は赤文字になります）
カレンダー形式にするのはなぜでしょうか？ 利用の回数を把握されたいのでしょうか...なら理解できます。
使用中は赤○に、使用後は、黒○、もしくは薄い○ではどうでしょうか？
※上記を踏まえると、このような表がお薦めになるのですが... 利用している駐車番号を、会社名を変更する使用方法ではダメなのでしょうか？ 既にフォームが決められているのならすいませんが無視してください。^^; （あみな） 2021/09/07(火) 16:09
月極駐車場ではなく、1日〇円利用料として会社に請求書をおこすので、利用回数が必要となります。
（更地を整備して駐車場にしている状態なので、簡単な線引きしかしておらず、駐車台数も限りがあるので、台数が溢れないように番号をつけて管理しています）
毎日借りにきた人に駐車番号が印字された紙をお渡しして、ダッシュボードに掲示してもらって、
エクセルにどこの会社が何番を使っているかを入力、返却に来たら返却したことがわかるように番号の色を変える。といった状態です。
1か月取りまとめたものを会社ごとに請求するので、シートは会社ごとに分けています。
たまに紙の返却忘れがあるため、どこの会社に何番を渡したかも把握できるように、駐車番号の入力で管理しています。
やはりマクロを勉強した方がよさそうですね・・・＞＜
（mammie） 2021/09/07(火) 16:28
＞やはりマクロを勉強した方がよさそうですね・・・＞＜
勉強なんてしなくて大丈夫ですよ^^ コードだけ貼り付けできれば問題ないです。 簡単ですよ。
上記の説明があれば皆さんより理解しやすいです。...うん
（*）さんがおっしゃるように シート名 (会社名) が固定なのであれば、そこに何番を使用しているか並べるほうが簡単だと思いますが
ちなみに利用する会社名は数100社とかまであるのでしょうか？ （あみな） 2021/09/07(火) 16:54
マクロでも、数式でも、レイアウト（行、列番号）を正確に伝えないと
無駄なやり取りが増えますよ。
（マナ） 2021/09/07(火) 17:27
なるほど
＞会社ごとにシートを作り、カレンダー表にして駐車した日に駐車番号を入力していきます。
と言うことは...会社ごとにシートが20枚あるのですね。
（マナ）さんのおっしゃるとうりで... （mammie）さんがカレンダー表のレイアウトと会社ごとにシートのレイアウトをちゃんと まずは説明しないと話が進みませんね。
まだカレンダーのテーブルフォームが変更可能なら下記のようなかんじがいいのかな？ これなら関数だけでいけるかな～と
|[A] |[B] |[C] |[D] |[E] |[F] |[G] |[H] |[I] |[J] |[K] |[L] |[M] |[N] |[O] |[P] |[Q] |[R] |[S] |[T] |[U] |[V] |[W] |[X] |[Y] |[Z] |[AA]|[AB]|[AC]|[AD]|[AE]|[AF]|[AG]
[1] | 2021| 9| | | | | | | | | | | | | | | | | | | | | | | | | | | | | | |
[2] | | |1日 |2日 |3日 |4日 |5日 |6日 |7日 |8日 |9日 |10日|11日|12日|13日|14日|15日|16日|17日|18日|19日|20日|21日|22日|23日|24日|25日|26日|27日|28日|29日|30日|1日
[3] |会社名|利用者|(水)|(木)|(金)|(土)|(日)|(月)|(火)|(水)|(木)|(金)|(土)|(日)|(月)|(火)|(水)|(木)|(金)|(土)|(日)|(月)|(火)|(水)|(木)|(金)|(土)|(日)|(月)|(火)|(水)|(木)|(金)
[4] |A社 |田中 | 1| 7| 2| 4| | 1| 3| | | | | | | | | | | | | | | | | | | | | | | |
[5] |B社 |安藤 | 2| 2| 3| | 7| 2| 4| | | | | | | | | | | | | | | | | | | | | | | |
[6] |C社 |木下 | 3| 3| 6| | | 4| 7| | | | | | | | | | | | | | | | | | | | | | | |
[7] |D社 |菅野 | 4| 4| 7| 6| | 6| 2| | | | | | | | | | | | | | | | | | | | | | | |
[8] |E社 |浅井 | 5| 5| 4| 2| | 5| 6| | | | | | | | | | | | | | | | | | | | | | | |
[9] |F社 |八木 | 6| 6| 1| | 5| 3| 1| | | | | | | | | | | | | | | | | | | | | | | |
[10]|G社 |北野 | 7| 1| 5| 5| 4| 7| 5| | | | | | | | | | | | | | | | | | | | | | | |
（あみな） 2021/09/07(火) 17:36
>やはりマクロを勉強した方がよさそうですね・・・＞＜
う～ん。そんな簡単ではないと思います。。。。
欲しい結果の補助としてエクセルを利用すると考えた方が無難かと。
そのためには、数式やピボットテーブル、フィルター等が使いやすいデータの保持の仕方を
まずは覚えることをお薦めします。
とりあえず、
今日の貸し出しに重複がないかのチェックは数式で表示。
月毎の会社毎の回数は、ピボットテーブルでカウント。
月毎の会社毎の履歴はフィルターオプションで抜き出してみる。
スライサーという機能も使えそうですし、
パワークエリとかという機能もありますよね？（今回の件で使えるかは不明）
その辺の機能の使い方を覚えた方が有用かと。
（まっつわん） 2021/09/08(水) 09:28
本来のレイアウトをちゃんとご説明させていただきます。
実際、1社に対して何人もの従業員の方が日々代わる代わる駐車をします。
駐車番号は1～71番まであります。
シート１（A社）
|[A] |[B] |[C] |[D] |[E] |[F] |[G] |[H] |[I] |[J] |[K] |[L] |[M] |[N] |[O] |[P] |[Q] |[R] |[S] |[T] |[U] |[V] |[W] |[X] |[Y] |[Z] |[AA]|[AB]|[AC]|[AD]|[AE]|[AF]|[AG]|[AH]|[AI]
[1] | 2021| 9| | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | |
[2] | | |1日 |2日 |3日 |4日 |5日 |6日 |7日 |8日 |9日 |10日|11日|12日|13日|14日|15日|16日|17日|18日|19日|20日|21日|22日|23日|24日|25日|26日|27日|28日|29日|30日|1日 |合計|金額
[3] |利用者|車番 |(水)|(木)|(金)|(土)|(日)|(月)|(火)|(水)|(木)|(金)|(土)|(日)|(月)|(火)|(水)|(木)|(金)|(土)|(日)|(月)|(火)|(水)|(木)|(金)|(土)|(日)|(月)|(火)|(水)|(木)|(金)| |
[4] |Aさん |12-34 | 1| 7| 2| 4| | 1| 3| | | | | | | | | | | | | | | | | | | | | | | | | 6 |3000
[5] |Bさん |23-45 | 2| 2| 3| | 7| 2| 4| | | | | | | | | | | | | | | | | | | | | | | | | 6 |3000
[6] |Cさん |34-56 | 3| 3| 6| | | 4| 7| | | | | | | | | | | | | | | | | | | | | | | | | 5 |2500
[7] |Dさん |45-67 | 4| 4| 7| 6| | 6| 2| | | | | | | | | | | | | | | | | | | | | | | | | 6 |3000
[8] |Eさん |56-78 | 5| 5| 4| 2| | 5| 6| | | | | | | | | | | | | | | | | | | | | | | | | 6 |3000
という表がシート１（A社）からシート２０（T社）まである、という感じです。
会社によって来られてる人数も違うので、人が増えると9行以降も続きます。
上記で、9/7現在でいうと、2・3・4・6・7番が赤文字で貸し出し中ということになります。
最悪、会社名（シート名）の表示ができなくても、使用中の番号（2・3・4・6・7番）がわかる・・・
という表ならもう少し簡単に作れますでしょうか？
なんせ、全シートの中から、赤文字の番号が１シートでわかるようにしたいのです。
ややこしくてすみません＞＜皆様のご回答本当に感謝しております。
（mammie） 2021/09/08(水) 11:06
これは、普通にVLOOKUP関数ですれば良いと思いますよ。多分^^; 下記のように、シート１（A社）と シート 2（B社）をまとめシートに抽出してみましょう。
◆VLOOKUP関数の構文(基本) =VLOOKUP（検索値, 範囲, 列番号, 検索の型）
まとめシートのB列には、1回だけなので各社の車両の情報及び、利用者は コピーでもしてください。
■シート１（A社）
|[A] |[B] |[C] |[D] |[E] |[F] |[G] |[H] |[I]
[1]| 2021| 9| | | | | | |
[2]| | |1日 |2日 |3日 |4日 |5日 |6日 |7日
[3]|利用者|車番 |(水)|(木)|(金)|(土)|(日)|(月)|(火)
[4]|Aさん |12-34| 1| 7| 2| 4| | 1| 3
[5]|Bさん |23-45| 2| 2| 3| | 7| 2| 4
[6]|Cさん |34-56| 3| 3| 6| | | 4| 7
[7]|Dさん |45-67| 4| 4| 7| 6| | 6| 2
[8]|Eさん |56-78| 5| 5| 4| 2| | 5| 6
■シート 2（B社）
|[A] |[B] |[C] |[D] |[E] |[F] |[G] |[H] |[I]
[1]| 2021| 9| | | | | | |
[2]| | |1日 |2日 |3日 |4日 |5日 |6日 |7日
[3]|利用者|車番 |(水)|(木)|(金)|(土)|(日)|(月)|(火)
[4]|Fさん |12-50| 6| 1| 15| | | 55| 36
[5]|Gさん |13-51| 7| 8| 11| 44| 8| 12| 24
[6]|Hさん |14-52| 8| 9| 16| | | 13| 23
[7]|Iさん |15-53| 9| 10| 28| 70| | 26| 67
[8]|Jさん |16-54| 10| 6| 30| 71| | 11| 21
■まとめシート
|[A] |[B] |[C]
[1] | 2021| 9|
[2] | | |1日
[3] |利用者|車番 |(水)
[4] |Aさん |12-34|=TEXT(VLOOKUP($B$4,Sheet1!$B$4:$AG$8,COLUMN()-1,FALSE),"#")
[5] |Bさん |23-45|=TEXT(VLOOKUP($B$5,Sheet1!$B$4:$AG$8,COLUMN()-1,FALSE),"#")
[6] |Cさん |34-56|=TEXT(VLOOKUP($B$6,Sheet1!$B$4:$AG$8,COLUMN()-1,FALSE),"#")
[7] |Dさん |45-67|=TEXT(VLOOKUP($B$7,Sheet1!$B$4:$AG$8,COLUMN()-1,FALSE),"#")
[8] |Eさん |56-78|=TEXT(VLOOKUP($B$8,Sheet1!$B$4:$AG$8,COLUMN()-1,FALSE),"#")
[9] |Fさん |12-50|=TEXT(VLOOKUP($B$9,Sheet2!$B$4:$AG$8,COLUMN()-1,FALSE),"#")
[10]|Gさん |13-51|=TEXT(VLOOKUP($B$10,Sheet2!$B$4:$AG$8,COLUMN()-1,FALSE),"#")
[11]|Hさん |14-52|=TEXT(VLOOKUP($B$11,Sheet2!$B$4:$AG$8,COLUMN()-1,FALSE),"#")
[12]|Iさん |15-53|=TEXT(VLOOKUP($B$12,Sheet2!$B$4:$AG$8,COLUMN()-1,FALSE),"#")
[13]|Jさん |16-54|=TEXT(VLOOKUP($B$13,Sheet2!$B$4:$AG$8,COLUMN()-1,FALSE),"#")
※ まとめシートのB列を、検索値にします。 ※ COLUMN関数で列を指定します。 ※ TEXT関数は、駐車番号が空白だと、0が表示されるので使用しています。 0を表示させない方法は他にもまだあるので検索で好きな方法を探してください。 ※ C列に式を入れたら最終列までコピペ(オートフィル)します。 ※ TEXT関数だと左寄になるので右寄にします。 ※ 各社の利用する人数が増えたら行を増やして式を貼り付け治すだけです。 ※ 後は、利用者が増えたら検索範囲も訂正してください。
■まとめシート結果
|[A] |[B] |[C] |[D] |[E] |[F] |[G] |[H] |[I]
[1] | 2021| 9| | | | | | |
[2] | | |1日 |2日 |3日 |4日 |5日 |6日 |7日
[3] |利用者|車番 |(水)|(木)|(金)|(土)|(日)|(月)|(火)
[4] |Aさん |12-34| 1| 7| 2| 4| | 1| 3
[5] |Bさん |23-45| 2| 2| 3| | 7| 2| 4
[6] |Cさん |34-56| 3| 3| 6| | | 4| 7
[7] |Dさん |45-67| 4| 4| 7| 6| | 6| 2
[8] |Eさん |56-78| 5| 5| 4| 2| | 5| 6
[9] |Fさん |12-50| 6| 1| 15| | | 55| 36
[10]|Gさん |13-51| 7| 8| 11| 44| 8| 12| 24
[11]|Hさん |14-52| 8| 9| 16| | | 13| 23
[12]|Iさん |15-53| 9| 10| 28| 70| | 26| 67
[13]|Jさん |16-54| 10| 6| 30| 71| | 11| 21
おちまい
きっとこれが一番簡単かな~と思ってます。(笑) でももっと良いアプローチがあるかもなので、数日はスレを覗いて見た方が良いと思います。
（あみな） 2021/09/08(水) 18:24
7日 (火) 3# 4# 7# 2# 6
この例では、6番はすでに利用が終わっていることを意味します。
どうしても色で区別したいということであれば、
以下は無視して、マクロを利用してください。
もう１つ、結果は同一ブックの別シートではなく
別ブックに抽出となります。
（同じブックでも可能ですが、別ブックのほうが簡単なので）
それでもOKのであれば、以下の手順で可能です。
１）新規ブックを用意（このブックに抽出します）
２）データ／データの取得／その他のデータソースから／空のクエリ
Power Queryエディターが起動する
３）ホーム／詳細エディター
４）下記をコピペ
２行目の ("C:\*****\駐車場利用実績.xlsx")
ここはデータがあるブックのパスに修正してください。
'-----
let
ソース = Excel.Workbook(File.Contents("C:\*****\駐車場利用実績.xlsx"), null, true),
削除された他の列 = Table.SelectColumns(ソース,{"Name", "Data"}),
#"展開された Data" = Table.ExpandTableColumn(削除された他の列, "Data", Table.ColumnNames(削除された他の列{0}[Data])),
削除された最初の行 = Table.Skip(#"展開された Data",2),
昇格されたヘッダー数 = Table.PromoteHeaders(削除された最初の行, [PromoteAllScalars=true]),
ピボット解除された他の列 = Table.UnpivotOtherColumns(昇格されたヘッダー数, {"A社", "利用者", "車番"}, "属性", "値"),
フィルターされた行 = Table.SelectRows(ピボット解除された他の列, each not Text.StartsWith([属性], "Column")),
フィルターされた行1 = Table.SelectRows(フィルターされた行, each [車番] <> null and [車番] <> "車番"),
#"名前が変更された列 " = Table.RenameColumns(フィルターされた行1,{{"属性", "利用日"}, {"値", "駐車番号"}}),
変更された型 = Table.TransformColumnTypes(#"名前が変更された列 ",{{"利用日", Int64.Type}}),
変更された型1 = Table.TransformColumnTypes(変更された型,{{"利用日", type date}, {"駐車番号", type text}}),
フィルターされた行2 = Table.SelectRows(変更された型1, each Text.EndsWith([駐車番号], "#")),
#"名前が変更された列 1" = Table.RenameColumns(フィルターされた行2,{{Table.ColumnNames(フィルターされた行2){0}, "会社名"}}),
置き換えられた値 = Table.ReplaceValue(#"名前が変更された列 1","#","",Replacer.ReplaceText,{"駐車番号"}),
変更された型2 = Table.TransformColumnTypes(置き換えられた値,{{"駐車番号", Int64.Type}}),
並べ替えられた行 = Table.Sort(変更された型2,{{"利用日", Order.Ascending}, {"駐車番号", Order.Ascending}})
in
並べ替えられた行
'-----
５）ホーム／閉じて読み込む
これで、Power Queryエディターが終了します
６）こんな感じの結果（テーブル）になります。
会社名 利用者 車番 利用日 駐車番号 A社 Dさん 45-67 2021/9/7 2 A社 Aさん 12-34 2021/9/7 3 A社 Bさん 23-45 2021/9/7 4 A社 Cさん 34-56 2021/9/7 7
７）以上は、最初の１回だけの操作で、次からは
６）のテーブルを右クリックし、「更新」を選択するだけです。
（マナ） 2021/09/08(水) 19:15
（マナ） 2021/09/08(水) 19:19
こんばんは。
TEXT関数は、やっぱり駄目です...すいません。数値にしてください。^^; 何故かと申し上げますと...文字列はカウントを下記のコードはしてくれませんww
下記のコードは、当日の...例えば今日(9月9日)の駐車番号を列で検索して空いてる 駐車番号を、MsgBox(メッセージダイアログ)に表示させるコードになります。 暇つぶしに作りました。まとめシートのテーブル形式が変わらないのならですが
見つけるのが楽ちんかな～と思い作りました。 まだ、実装実験を多くしていないのでお試し版となります。
まとめシートのセルに次の関数を置いて使用します。 =MATCH(TODAY(),C2:AG2, 0)
Sub Sample_Key0_Find()
Dim ws As Worksheet
Dim i, xRow, MyCol As Long
Dim Key0_Find As String
Dim RetMsg As VbMsgBoxResult
Set ws = ActiveSheet
Const START_ROW = 4&
Const MAX_ROW = 100&
On Error Resume Next
MyCol = WorksheetFunction.Match(CLng(Date), Range("C2:AG2"), 0)
If Err.Number = 0 Then
Cells(1, MyCol + 2).Value = Range("AK2").Value ' セルに当日の確認日付を入力する
xRow = WorksheetFunction.Max(Range(ws.Cells(START_ROW, MyCol + 2), ws.Cells(20, MyCol + 2)))
For i = 1 To xRow
If Range(ws.Cells(START_ROW, MyCol + 2), ws.Cells(MAX_ROW, MyCol + 2)).Find(i, , , xlWhole) Is Nothing Then _
Key0_Find = Key0_Find & i & "、" ' & vbCrLf
Next i
Else
MsgBox "今日の日付を検出できません", vbExclamation
Exit Sub
End If
On Error GoTo 0
RetMsg = MsgBox(" 駐車番号が空いているのは、" _
& vbCrLf _
& vbCrLf _
& Key0_Find & vbCrLf _
& vbCrLf _
& "上記の番号になります。", _
vbOKOnly + vbInformation, Title:="INFOMATION")
End Sub （あみな） 2021/09/09(木) 00:55
追記
AK2=MATCH(TODAY(),C2:AG2, 0)
ではでは。おやすみなさい。 （あみな） 2021/09/09(木) 00:58
私には難易度高すぎて解読に時間がかかりそうです・・・。
が、本当に感謝しております！！
私のわがままな希望を色々考えてくださって＞＜
本当にありがとうございます！！
（マナ）様
色がカウントできないなら、記号を入れるのは目からうろこでした！！
Power queryは全然知らなかったです。
これを機に色々勉強してみようと思います！
（あみな）様
作っていただいてありがとうございます！
暇つぶしで作れてしまうなんて・・・天才でしょうか。
お試し版、できれば活用させていただきたいと思います。
ありがとうございました＞＜
（mammie） 2021/09/09(木) 11:47
こんばんは。
＞暇つぶしで作れてしまうなんて・・・天才でしょうか。
そんな訳がありません。ここの上級者(プロ)の方々と比べたら 私なんて足元にも及びませんよ。へなちょこですから。(笑)
お試し版コードは、まだ未完成です。不都合が発覚しました。^^;
直接入力した数値は検出されますが、数式が入った場合は セルの数式を調べて変数に代入し、数式の値を「取得」するように しないとダメかもと解りました。
すぐに治せるかわかりませんので、また声を掛けてください。
↑治せなかったらここの上級者(プロ)さん達に (*ゝﾉｖ･)ｺｯｿﾘ 内緒で聞いときますから
秘密ですよ (*￣ ￣)b シー
完成したらスレにUPしときます。
（ あみな） 2021/09/09(木) 20:58
一応、駐車場の表は直接駐車番号を数値で入力しているので
数式に反応することはないと思うのですが・・・。
まだちゃんと理解できていないので
載せていただいた式を熟読させていただきます！
（mammie） 2021/09/10(金) 09:28
VLOOKUP で調整するんかな？
Pewer Query は、少々勉強しないといけませんからね。
ひとつ、私の勉強の為に質問して良いですか？ えっと、駐車場貸出しシートを各社ごとに分けようと 最初に決めたのは、経理の方ですかね？
その方が、請求書出し易いからそうしたのかな？ （あみな） 2021/09/10(金) 10:33
駐車場の管理はすべて私が取り決めて処理してます。
各社ごとにしたのは、毎月月末締めで請求をするのですが
その内訳として証憑するために分けました。
あと見やすさと処理のしやすさ・・・ですね。
１シートにずーーと下に表が連なるのはあまり好きではなくて
１社１ページで収まる程度の表なので、スクロールする手間を省く、
という点でもシートを分けました。
なんせ毎日、代わる代わる色んな会社の色んな方が使用されるので
日々入力、人の追加、会社の追加・・・というかんじなので＾＾：
今更ですが他に何かいい方法ありましたかね＞＜
（mammie） 2021/09/10(金) 12:08
(・0・。) ほほーっ...
＞駐車場の管理はすべて私が取り決めて処理してます。
いいなー生涯でなかなか出来る機会のある事ではありませんね。 ちょっとしてみたかったりして(笑) でも、意外とハードワークで間違えれないから神経も使いますね。＞＜
＞今更ですが他に何かいい方法ありましたかね＞＜
既に各社シートを20枚程作成して、スタートしてしまっているので 切替は難しいと思いますが、 VLOOKUP でまとめるのは、苦肉の策です。^^;
20社分のシートを参照させるのって結構な手間が掛かるかな～と思ってます。 時間で１～２時間かな？
VBAでするのも大変かもしれないです。簡単なら他の誰か閲覧された方が既に 提案してそうですし...分散したシートの情報をまとめるのは私はVBAでした事が ないんですよね。その必要が無いようにしてるからです。
長くなるので今日は記載しませんが...私ならこのようにするかな～つてのを 今後の参考になるかもなので近い内に「レス」しときます。^^ （あみな） 2021/09/11(土) 00:22
シート分けるとやっぱり難しいですよね。
とりあえず手入力しながら、間違えないように処理するしかないですね～～笑
あみな様の手間もたくさんとらせてしまって本当に申し訳ないです！
暇でヒマで仕方なくて・・・の時間があれば！よろしくお願いします＞＜
たくさんのレスでかなり勉強になりました！！
本当にありがとうございます！！
（mammie） 2021/09/13(月) 10:57
＞駐車番号は1～71番まであります。
と言うことは、実際は、この右にずらーっと並ぶんですね。うーん、ピンとこないですねぇ。 ↓ ＞これを、さらに別シートを作り、。 ＞1 2 3 4 5 6 7 8 9 10 ・・・・・ ＞ a b
私なら全貌表(下図）を作って、処理するなぁ。
１．会社名の行(5～6行目)は、全シート名から自動的に書き出して置く
２．借入に来たら、会社名と社員名を聞く
その会社名を4～5行から見つけて、ダブルクリックする。 すると、C2セルにその会社名が転記される。
すると、A列にでも当該会社の社員一覧が表示される。 そこでその社員名をダブルクリックすると、C3セルに当該社員名が入力される。
その後、全貌シート上にある駐車場Noで貸出せるセル(まだ色が付いてないセル）の一つを ダブルクリックする。
すると、ダブルクリックされた駐車場NOセルは、赤バック黄色文字で 33(b社)とかの表示へ変わる。
同時に、当該貸出情報を該当会社シートの該当社員のセルに自動的に反映させる。
その後、返却があった場合は、当該駐車Noのセル(色付き）をダブルクリックすると 単なる33に変化する。
それなら、一目瞭然に貸出状況がわかるし、人の手間も少ない。 (3回ダブルクリックする程度。コーディング量は増えますけどね・・）
<全貌表 シート > 行 _A_ ____B____ ___C___ __D__ __E__ ___F___ __G__ __H__ __I__ __J__ __K__ __L__ 1 2 貸出先名 3 社員名 4 5 会社 a社 b社 3社 4社 5社 6社 7社 8社 9社 10社 6 11社 12社 13社 14社 15社 16社 17社 18社 19社 20社 7 予備行 8 9 駐車場NO 1 2 3 4(a社） 5 6 7 8 9 10 10 11 12 13 14 15 16 17 18 19 20 11 21 22 23 24 25 26 27 28 29 30 12 31 32 33 34 35 36 37 38 39 40 13 41 42 43 44 45 46 47 48 49 50 14 51 52 53 54 55 56 57 58 59 60 15 61 62 63 64 65 66 67 68 69 70 16 71
（半平太） 2021/09/13(月) 18:01
できるだけシート1枚１画面でスクロールせずに見れるようにしたいので
右にずら～っと７１まで並べるというよりかは
半平太さまが作ってくださったような表にしたいですが、
他シートからそのデータを反映させる方法がわからなくて・・・。
会社ごとにシートは分けたいのです。
停めたら入れる、返却されたら消すだけでなく、いつどこの誰が使用したかをずっと残して
請求をおこすので、難しいなぁと・・・＞＜
考えてくださってありがとうございます！
（mammie） 2021/09/14(火) 15:51
＞それはマクロを使用して・・・ということでしょうか？＾＾；
はい、そうです。
マクロ使用が問題じゃなければ、コードを書いて上げますけど・・
（半平太） 2021/09/14(火) 16:21
（mammie）さん 良かったですね。(*´∀`*)
（半平太）さん...プロがマクロ作ってくれるって... ((*p'∀'q))楽しみですね。
このマクロって難易度高くないのかな？ 私も、20枚の各社シート作って待機してるわぁ(笑) （あみな） 2021/09/14(火) 17:05
＞１．会社名の行(5～6行目)は、全シート名から自動的に書き出して置く P2セルをダブルクリックすると書き出されるようにしました。
＞ダブルクリックされた駐車場NOセルは、赤バック黄色文字で ＞33(b社)とかの表示へ変わる。 これは「33(b社)->山田」と言う表示に変更します。 つまり、「駐車場NO(会社名)->社員名」の形にします。
理由は、返却時に、会社シートの山田さんのフォントの色を元に戻さないとならないのですが、 社員名が分からないと面倒な為。
あと、元に戻す操作はできないので、「あれ？俺いま何やったっけ・・」なんて状況になるとマズいので、 R列～V列にデータ更新履歴を書き出すことにしました。 それを見て必要な訂正作業を行ってください。
では、以下の手順で準備作業を行ってください。
ーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーー 一枚新規シートを挿入して、「全貌表」と名前を付けてください。
(1)全貌表シートの「シート見出し」を右クリックして、「コードの表示(V)」を選ぶ。 すると、画面中央に白いエリアが出ます。(VBE画面と呼ばれています。)
(2)そのエリアに下記マクロ「onlyOnce」を貼り付ける。 (3)F5キーを押下する(マクロが実行されて、所要データが埋まります。 (4)Ctrl+ｚキー押下で、貼付け前に戻す(onlyOnceは一回こっきりしか使わない為）
(5)再度下記常駐マクロを貼り付ける (6)ALT+F11でエクセルに戻る
P2セルをダブルクリックして、会社名を打ち出す。
あとは、前レスで説明した通りの使い勝手です。
ーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーー ’一回こっきりしか使わない。すぐ消える運命。
Private Sub onlyOnce()
With Me
.Range("R2:R500").NumberFormatLocal = "yyyy/m/d h:mm"
.Range("B2").Value = "貸出先名"
.Range("B3").Value = "社員名"
.Range("B9").Value = "駐車場NO"
.Range("P2").Value = "会社名更新"
.Range("Q2").Value = "履歴"
.Range("R2").Value = "日時"
.Range("S2").Value = "INOUT"
.Range("T2").Value = "会社"
.Range("U2").Value = "社員"
.Range("V2").Value = "駐車場"
.Range("C9").Value = 1
.Range("D9:L9").FormulaR1C1Local = "=RC[-1]+1"
.Range("C10:L15").FormulaR1C1Local = "=R[-1]C+10"
.Range("C9:L15").Value = .Range("C9:L15").Value
.Range("C16").Value = 71
End With
Range("C9:L20").FormatConditions.Add Type:=xlExpression, Formula1:="=FIND(""("",C9)"
With Range("C9:L20").FormatConditions(1)
.Font.Color = -16711681
.Interior.Color = 255
End With
Range("C5:L7").FormatConditions.Add Type:=xlExpression, Formula1:="=AND($C$2=C5,C5<>"""")"
With Range("C5:L7").FormatConditions(1)
.Interior.Color = 65535
End With
Range("A3:A500").FormatConditions.Add Type:=xlExpression, Formula1:="=AND($C$3=A3,A3<>"""")"
With Range("A3:A500").FormatConditions(1)
.Interior.Color = 65535
End With
End Sub
ーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーー ’常駐プログラム。これ以降のは、貼り付けたらそのまま残す。
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
Dim r As Range, CompanyName, EmployeeName, ComPOS, EmpPOS, ClRwPOS
If Target.Address(0, 0) = "P2" Then
updateWorksheetsName
Exit Sub
End If
Set r = Intersect(Target, Range("C5:L7")) '会社名処理
If Not r Is Nothing Then
Cancel = True
Range("C2") = Target
Range("C3").ClearContents '社員名セルはクリアする
'当該社員名リストをA列に表示する。
Me.Range("A3:A500").ClearContents
With Worksheets(Range("C2").Value)
.Range("A2", .Cells(.Rows.Count, "A").End(xlUp)).Copy
Me.Range("A3").PasteSpecial xlPasteValues
End With
Exit Sub
End If
Set r = Intersect(Target, Range("A3:A501")) '社員名処理
If Not r Is Nothing Then
Cancel = True
Range("C3") = Target
Exit Sub
End If
Set r = Intersect(Target, Range("C9:L20")) '駐車場NO処理
If Not r Is Nothing Then
Cancel = True
'返却処理
If Target Like "*(*)->*" Then
'駐車場NOセルから会社名取得
ComPOS = InStr(Target, "(")
EmpPOS = InStr(Target, "->")
CompanyName = Mid(Target, ComPOS + 1, EmpPOS - ComPOS - 2)
EmployeeName = Mid(Target, EmpPOS + 2, Len(Target))
Target = Left(Target, InStr(Target, "(") - 1) '返却状態に戻す
ClRwPOS = getClRWPOS(CompanyName, EmployeeName)
Worksheets(CompanyName).Cells(ClRwPOS(2), ClRwPOS(1)).Font.ColorIndex = xlAutomatic
recordLog Array(Now, "返却", CompanyName, EmployeeName, Target.Value)
Exit Sub
End If
'貸出処理
If Application.CountA(Range("C2:C3")) < 2 Then
MsgBox "貸出先名(C2セル）と社員名(C3) を先に決定してください"
Exit Sub
End If
CompanyName = Range("C2")
EmployeeName = Range("C3")
ClRwPOS = getClRWPOS(CompanyName, EmployeeName)
If Not IsError(ClRwPOS(1)) And Not IsError(ClRwPOS(2)) Then
With Worksheets(CompanyName).Cells(ClRwPOS(2), ClRwPOS(1))
.Value = Target.Value
.Font.Color = vbRed
recordLog Array(Now, "貸出", CompanyName, EmployeeName, Target.Value)
End With
Target.Value = Target & "(" & Range("C2") & ")->" & Range("C3")
Range("A3:A501,C2:C3").ClearContents ’会社名と社員名をクリアする
End If
End If
End Sub
Private Function getClRWPOS(wsName, empName)
Dim ret(1 To 2)
ret(1) = Application.Match(CLng(Date), Worksheets(wsName).Rows(1), 0)
If Not IsNumeric(ret(1)) Then
MsgBox wsName & "の一行目に本日の日付がありません。日付のメンテをしてください。"
End If
ret(2) = Application.Match(empName, Worksheets(wsName).Range("A1:A500"), 0)
If Not IsNumeric(ret(2)) Then
MsgBox wsName & "にその社員は居ません。社員名のメンテをしてください"
End If
getClRWPOS = ret
End Function
Private Sub recordLog(Logs)
Me.Range("R3:V499").Copy Me.Range("R4")
Me.Range("R500:V500") = Empty
Me.Range("R3:V3") = Logs
End Sub
Private Sub updateWorksheetsName()
Dim WsNames(1 To 3, 1 To 10)
Dim Ws As Worksheet, Rw As Long, Cl As Long
Rw = 1
Cl = 0
For Each Ws In ThisWorkbook.Worksheets
If Ws.Name <> Me.Name Then
Cl = Cl + 1
If Cl > 10 Then
Cl = 1
Rw = Rw + 1
End If
WsNames(Rw, Cl) = Ws.Name
End If
Next
Me.Range("C5:L7") = WsNames
End Sub
（半平太） 2021/09/14(火) 23:24
ただ・・・駐車場Noを押すと「"の一行目に本日の日付がありません。日付のメンテをしてください。"」
のエラーが出てしまいます。
きっと元々私が作っていた会社別のシートの表に問題があるんですよね。
何をどう修正したらいいのかわかりません＞＜
せっかく作っていただいて、あと一歩のところなのでなんとも悔しいです・・・＞＜
もう少しお力添えしていただけないでしょうか。
今、もともと作って使っている会社別シートは上記に一度記載したとおり、
|[A] |[B] |[C] |[D] |[E] |[F] |[G] |[H] |[I] |[J] |[K] |[L] |[M] |[N] |[O] |[P] |[Q] |[R] |[S] |[T] |[U] |[V] |[W] |[X] |[Y] |[Z] |[AA]|[AB]|[AC]|[AD]|[AE]|[AF]|[AG]|[AH]|[AI]
[1] | 2021| 9| | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | |
[2] | | |1日 |2日 |3日 |4日 |5日 |6日 |7日 |8日 |9日 |10日|11日|12日|13日|14日|15日|16日|17日|18日|19日|20日|21日|22日|23日|24日|25日|26日|27日|28日|29日|30日|1日 |合計|金額
[3] |利用者|車番 |(水)|(木)|(金)|(土)|(日)|(月)|(火)|(水)|(木)|(金)|(土)|(日)|(月)|(火)|(水)|(木)|(金)|(土)|(日)|(月)|(火)|(水)|(木)|(金)|(土)|(日)|(月)|(火)|(水)|(木)|(金)| |
[4] |Aさん |12-34 | 1| 7| 2| 4| | 1| 3| | 2 | 2 | | | | 9 | 9 | | | | | | | | | | | | | | | | | 6 |3000
[5] |Bさん |23-45 | 2| 2| 3| | 7| 2| 4| 4| | | | | 3 | | | | | | | | | | | | | | | | | | | 6 |3000
[6] |Cさん |34-56 | 3| 3| 6| | | 4| 7| 7| | | | | | | | | | | | | | | | | | | | | | | | 5 |2500
[7] |Dさん |45-67 | 4| 4| 7| 6| | 6| 2| | 1| | 5 | | | | 6 | | | | | | | | | | | | | | | | | 6 |3000
[8] |Eさん |56-78 | 5| 5| 4| 2| | 5| 6| | 3| | | | 1 | 1 | 1 | | | | | | | | | | | | | | | | | 6 |3000
とういうように入っています。今日（9/15）時点で借りている人のところには駐車番号が手入力してあります。
日付け C1セルには"=B1"と入力し、書式設定で"d"とし、日のみ表示するようにしています。D列以降は"=C2+1"としています。
どこが原因でエラーが出ているかもわかっていないので、そもそも意味のない説明をしているかもしれませんが・・・
ごめんなさい；＿；
（あみな）様
たくさんのレス本当に感謝です。
私にはレベルが高すぎな質問をしてしまっていました＾＾；
あみな様のように親切にしてくださる方がいて本当に感無量でございます＞＜
あみな様20社シート作れました？笑
（mammie） 2021/09/15(水) 09:15
あれれ？ 私はこれだと思い込んでいました。m(__)m ↓ ＞シート名【a社】 ＞ A B C D E ・・・ ＞1 9/1 9/2 9/3 9/4 ・・・ ＞2 佐藤 1 ・・・ ＞3 田中 2 2 ・・・
＞日付け C1セルには"=B1"と入力し、書式設定で"d"とし、日のみ表示するようにしています。 そこが分かりません。
１．B1セルは「9」に見えますが、実際は「2021/9/1」の日付シリアル値なのでしょうか？ ２．日付はAG列までですね？ ３．日付またがりの入出庫ってあるのでしょうか？(深夜0時には全部返却になるのでしょうか？）
４．車番は社員名と1対1なのですか？ それとも、Aさんは別の45-68にも乗るんでしょうか。 そういうことがある場合 ※別の行にもAさんを書くのでしょうか？ それとも車番12-23を45-68に変更して1行で使っているのでしょうか？
その実態次第では、全貌表の操作において車番も考慮しないとならなくなるのですが・・
（半平太） 2021/09/15(水) 10:01
＞車番と社員名は1対1です。 ＞車番を考慮するとなるとまた色々式が変わってきます…よね？汗
1対1なら、車番をチェックに行く必要がないので、影響は軽微です。
＞連日借りる場合もあるので、必ず1日で返却とは限りません。 それより、こっちが面倒です。 未返却が続くと、会社シートの翌日、翌々日にも駐車場NOデータを移さなければならないですよね？
今は、手作業で左の駐車場NOを右へコピーしているんですか？ いつやっているんですか？(朝一ですか？） ※兎に角、その作業を何とか自動化する必要があります。
（半平太） 2021/09/15(水) 11:41
20社シート、もう作って実行してますよ。(ゝω・)v
（半平太）先生...素晴らしいです。ちゃんと動いてますよ。
（mammie）さんへ
私も最初ここで止まりました。 駐車場Noを押すと「"の一行目に本日の日付がありません。日付のメンテをしてください。"」
A1=2021 B1=9 だけだったので勿論止まりましたが 1行目の適当な処にでも、9/15シリアル値作ったらコード走りましたよ。
（半平太）先生へ
＞あれれ？ 私はこれだと思い込んでいました。m(__)m ↓ ＞シート名【a社】 ＞ A B C D E ・・・ ＞1 9/1 9/2 9/3 9/4 ・・・ ＞2 佐藤 1 ・・・ ＞3 田中 2 2 ・・・
これだと思ってたからだと思います。
■同時に、当該貸出情報を該当会社シートの該当社員のセルに自動的に反映させる。
最後の入力がだけが、今日の場合は15日なので、[Q]列に反映されないといけなんですけど D列に反映されちゃうですね。
■ダブルクリックされた駐車場NOセルは、赤バック黄色文字で 33(b社)とかの表示へ変わる。
表示はバッチリ切り替わりますが → 6(F社)->安藤 今のところ...色が付かない^^;
今、マクロみてます。 ここの参照を治せばいいのかしら...
Private Function getClRWPOS(wsName, empName)
（あみな） 2021/09/15(水) 12:52
あ、解かりました。
1行目の下記の式で列を認識してるですね。 =DATE($A$1,$B$1,COLUMN()-2) （あみな） 2021/09/15(水) 12:57
（mammie）さんへ
＞駐車場Noを押すと「"の一行目に本日の日付がありません。日付のメンテをしてください。"」
Private Function getClRWPOS(wsName, empName)
Dim ret(1 To 2)
ret(1) = Application.Match(CLng(Date), Worksheets(wsName).Rows(1), 0)
略
End Function
こうすれば、Rows(2)2行目を参照すれば...はしりました。 ret(1) = Application.Match(CLng(Date), Worksheets(wsName).Rows(2), 0) （あみな） 2021/09/15(水) 13:19
>未返却が続くと、会社シートの翌日、翌々日にも駐車場NOデータを移さなければならないですよね？ >今は、手作業で左の駐車場NOを右へコピーしているんですか？ > いつやっているんですか？(朝一ですか？） 毎朝、使用状況をチェックして、右へ数字を並べています。 月末に1回整理して一気に請求を起こすので、今はこの連日の人たちの入力は割と忘れがちで 返却した人だけ日々入力できていて、月末にチェックした時に返却ない人は数字を右にコピーーーー！ という感じになっています＾＾；
（あみな）様
す・・・すごい！仕事が早いですーーー！！
ありがとうございます！ちょっとそれでやってみます＞＜
解読できないともう何がなんだかですね・・・；＿；
（mammie） 2021/09/15(水) 14:17
あみなさんへ 私はプロでも、先生でもありません。
mammieさんへ
＞毎朝、使用状況をチェックして、右へ数字を並べています。 ＞月末に1回整理して一気に請求を起こすので、今はこの連日の人たちの入力は割と忘れがちで ＞返却した人だけ日々入力できていて、月末にチェックした時に返却ない人は数字を右にコピーーーー！ ＞という感じになっています＾＾；
毎朝、前日赤字のままの駐車NOだけ、当日列にコピーってのを自動でやれば楽になりそう。
でも、深夜の営業ってどうなっていますか？ 夜10時に借りにきて、深夜1時に返却があったら「朝一の作業でコピペ」なんて言ってられません。 本人たちも、翌日になったとも思ってないかも知れません。
営業は夜8までとかなら、その心配はないので有難いですけどね。
＞解読できないともう何がなんだかですね・・・；＿； 当面、そんな心配いらないです。 最終的にチャンと動くコードをアップしますので。 そのあと、時間があったらコードの解読でも何でもしてください。
（半平太） 2021/09/15(水) 14:31
（半平太）さんへ
それは、失礼しました。 （あみな） 2021/09/15(水) 14:41
一応営業はだいたい朝7時から夜は5時、遅くても6時の間しか稼働しないので
深夜は動きません。だいたい私の勤務時間で終わります。
日付け、あみな様が教えてくださったところを修正したら
ちゃんと動きましたーーーー！！！！
感動して声が一瞬出なくなりましたー！！！
すごすぎる・・・これは毎日の処理が楽しくなりそうです・・・！！！
（mammie） 2021/09/15(水) 14:54
＞例えば私が1日あけてしまった場合、前日に遡って番号を入力したいとなると ＞どうすればいいのでしょうか それは一律処理なので、何か工夫をすれば出来ると思います。
＞あと、もし赤字の番号だけ隣のセルにコピーも、日曜だけ外す。とかもできますか？？ こっちの事情がよく分かりません。 日曜って、借りっぱなしでも無料なんですか？ なぜ外す必要があるんですか？
（半平太） 2021/09/15(水) 15:20
＞日曜は休業日なのでカウントしないんです。 １．なら初めから、カレンダーから除外して置いたら、手間がないじゃないですか？ 必ず、隣り合っている列は営業日である、と言うことになってロジックがシンプルになります。
２. ちなみに、祝日もこの話に関係して来ないのですか？
（半平太） 2021/09/15(水) 15:42
＞イレギュラーな休日はまれにありますが
エクセル的に言えば、それが祝日ということになります。
その日付(もしあれば）を何処か決まったエリアに入れて置くとして、 日曜とその休日を避けて、赤駐車場NOを翌営業日に繰り越す、と言う仕様になりますね。
＞例えば私が1日あけてしまった場合、前日に遡って番号を入力したいとなると ＞どうすればいいのでしょうか・・・ 話題を戻して、その件ですが、あけた1日を追っかけ入力すると言うことなんでしょうか？ ※丸1日分の入力データ(メモ書き？）がどっかにあると言う事なんですか？
（半平太） 2021/09/15(水) 16:17
話題を戻して、その件ですが、あけた1日を追っかけ入力すると言うことなんでしょうか？ ※丸1日分の入力データ(メモ書き？）がどっかにあると言う事なんですか？
今、駐車場を借りる際には毎朝、来られた人に申込書を書いてもらって
それを控えとしてとってあります。
その控えを見ながら私がエクセルにデータを入力しているという状態です。
その申込書と引き換えに許可証をお渡しして、ダッシュボードに掲示してもらっていて、
返却は許可証に返却日を記入して返してもらうだけ、という流れです。
私がひたすらその申込書や許可証を見て、データを入力しています。
（mammie） 2021/09/15(水) 16:33
分かりました。暇をみて作りこんでみます。
多分「おっかけ入力」も「借りっぱなし繰越処理」も、 「仮想本日」をどこかに入力してもらって、 その日を基準に、1日ずつ片付けて行く仕掛けになると思います。
いずれも朝一処理じゃないと対応は無理です。 (当日のデータを何件か処理したあと、そんな例外処理を始めたら滅茶苦茶になります。)
（半平太） 2021/09/15(水) 16:48
「おっかけ入力」と「借りっぱなし繰越処理」を一緒くたにしてしまいましたが、 「借りっぱなし繰越処理」はほぼ一瞬で終わるハズなので、 朝一と言ってもそんなストレスはないと思います。
（半平太） 2021/09/15(水) 17:00
１．全貌表シートのP列に下図の通り、項目名を入力する。
行 _______P_______ 1 2 会社名更新 3 4 仮想本日 5 6 7 前営業日 8 9 10 未返却繰延処理 11 12 13 例外休日
※例外休日があれば、P14:P31にその日付を入れてください。
２．E2セルに「仮想本日有無」と言う項目名を入力する
３．以下の数式を入力する。 (1) P8セル =WORKDAY.INTL(IF(P5="",TODAY(),P5),-1,11,P14:P31) (2) E3セル =IF(P5<>"","あり→要注意!","")
４．追加仕様の操作方法 (1) 未返却繰延べ処理は毎日朝一で行う。 P10セルをダブルクリックすると各社の当日列に自動転記されます。
(2)追いかけ入力 朝一で、追付くべき日付をP5セルに入れる。 (複数日に渡る場合は、古い日付から1日ずつ行う）
あたかもその日だと思って、通常の処理を行うだけです。 つまり、まず未返却繰延処理を行う。その後、申込書を見ながら、貸出し・返却関連処理を行う。
※果たして省力化されるかは分かりません。今までの方法と手間は変わりないかもです。
５。常駐マクロを下記のものに全とっかえしてください。
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
Dim r As Range, cel As Range, CompanyName, EmployeeName, ComPOS, EmpPOS, ClRwPOS, vtlToday As Date
Dim ColoredST As Long, ColoredED As Long, i As Long, Span As String
vtlToday = VerturalToday
If Me.[WORKDAY.INTL(P8,1,11,P14:P31)=IF(P5="",TODAY(),P5)] = False Then
Cancel = True
MsgBox "休日は作業日にしないでください。仮想本日を使ってください。"
Exit Sub
End If
If Target.Address(0, 0) = "P2" Then
updateWorksheetsName
Cancel = True
Exit Sub
ElseIf Target.Address(0, 0) = "P10" Then
Cancel = True
carryOverProc
Exit Sub
End If
Set r = Intersect(Target, Range("C5:L7")) '会社名処理
If Not r Is Nothing Then
Cancel = True
Range("C2") = Target
Range("C3").ClearContents '社員名セルはクリアする
'当該社員名リストをA列に表示する。
Application.ScreenUpdating = False
Me.Range("A3:A500").ClearContents
With Worksheets(Range("C2").Value)
.Range("A4", .Cells(.Rows.Count, "A").End(xlUp)).Copy
Me.Range("A3").PasteSpecial xlPasteValues
Me.Range("A3").Select
End With
Application.ScreenUpdating = True
Exit Sub
End If
Set r = Intersect(Target, Range("A3:A501")) '社員名処理
If Not r Is Nothing Then
Cancel = True
Range("C3") = Target
Exit Sub
End If
Set r = Intersect(Target, Range("C9:L20")) '駐車場NO処理
If Not r Is Nothing Then
Cancel = True
'返却処理
If Target Like "*(*)->*" Then
'駐車場NOセルから会社名取得
ComPOS = InStr(Target, "(")
EmpPOS = InStr(Target, "->")
CompanyName = Mid(Target, ComPOS + 1, EmpPOS - ComPOS - 2)
EmployeeName = Mid(Target, EmpPOS + 2, Len(Target))
Target = Left(Target, InStr(Target, "(") - 1) '返却状態に戻す
ClRwPOS = getClRWPOS(CompanyName, EmployeeName)
'会社シートの赤NOを遡って黒に変更した場合、その期間を表示する
ColoredST = ClRwPOS(1)
ColoredED = ClRwPOS(1)
With Worksheets(CompanyName)
For i = ClRwPOS(1) - 1 To 3 Step -1 '最大C列まで
If .Cells(ClRwPOS(2), i).Value <> "" And .Cells(ClRwPOS(2), i).Font.Color = vbRed Then
ColoredST = i
End If
Next
Span = Day(.Cells(2, ColoredST)) & "～" & Day(.Cells(2, ColoredED))
End With
Worksheets(CompanyName).Cells(ClRwPOS(2), 3).Resize(1, ClRwPOS(1)).Font.ColorIndex = xlAutomatic
recordLog Array(Now, "返却済" & Span, CompanyName, EmployeeName, Target.Value)
Exit Sub
End If
'貸出処理
If Application.CountA(Range("C2:C3")) < 2 Then
MsgBox "貸出先名(C2セル）と社員名(C3) を先に決定してください"
Exit Sub
End If
CompanyName = Range("C2")
EmployeeName = Range("C3")
ClRwPOS = getClRWPOS(CompanyName, EmployeeName)
If Not IsError(ClRwPOS(1)) And Not IsError(ClRwPOS(2)) Then
With Worksheets(CompanyName).Cells(ClRwPOS(2), ClRwPOS(1))
.Value = Target.Value
.Font.Color = vbRed
recordLog Array(Now, "貸出", CompanyName, EmployeeName, Target.Value)
End With
Target.Value = Target & "(" & Range("C2") & ")->" & Range("C3")
Range("A3:A501,C2:C3").ClearContents
End If
End If
End Sub
Private Function getClRWPOS(wsName, empName)
Dim vtlToday As Date
vtlToday = VerturalToday
Dim ret(1 To 2)
ret(1) = Application.Match(CLng(vtlToday), Worksheets(wsName).Range("A2:AG2"), 0)
If Not IsNumeric(ret(1)) Then
MsgBox wsName & "の「A2:AG2」に本日の日付がありません。日付のメンテをしてください。"
End If
ret(2) = Application.Match(empName, Worksheets(wsName).Range("A1:A500"), 0)
If Not IsNumeric(ret(2)) Then
MsgBox wsName & "にその社員は居ません。社員名のメンテをしてください"
End If
getClRWPOS = ret
End Function
Private Sub recordLog(Logs)
Me.Range("R3:V499").Copy Me.Range("R4")
Me.Range("R500:V500") = Empty
Me.Range("R3:V3") = Logs
End Sub
Private Sub updateWorksheetsName()
Dim WsNames(1 To 3, 1 To 10)
Dim Ws As Worksheet, Rw As Long, Cl As Long
Dim ret(1 To 2)
Dim r As Range, vtlToday, cel As Range, i As Long, Tgt As Range
Rw = 1
Cl = 0
For Each Ws In ThisWorkbook.Worksheets
If Not Ws Is Me And Ws.Name <> "集計表" Then
Cl = Cl + 1
If Cl > 10 Then
Cl = 1
Rw = Rw + 1
End If
WsNames(Rw, Cl) = Ws.Name
End If
Next
Me.Range("C5:L7") = WsNames
vtlToday = VerturalToday
'赤番号を全貌表に逆反映
Set r = Me.Range("C9:L20")
With r '一旦全部クリア
For i = 1 To .Cells.Count
If .Cells(i) <> "" Then
.Cells(i) = i
End If
Next i
End With
For Each Ws In ThisWorkbook.Worksheets
If Not Me Is Ws And Ws.Name <> "集計表" Then
ret(1) = Application.Match(CLng(vtlToday), Ws.Range("A2:AG2"), 0)
If Not IsNumeric(ret(1)) Then
MsgBox Ws.Name & "の「A2:AG2」に本日の日付がありません。日付のメンテをしてください。"
Exit Sub
End If
With Ws
For i = 4 To .Cells(.Rows.Count, ret(1)).End(xlUp).Row
Set Tgt = .Cells(i, ret(1)) '会社シートの個々の駐車場NOのセル
If Tgt <> "" Then
If Tgt.Font.Color = vbRed Then
If Application.CountIf(r(Tgt.Value), "*(*)->*") > 0 Then
MsgBox Ws.Name & " " & .Cells(i, "A") & "さんのNO(" & Tgt & ")が、ダブっています。処理中止"
Exit Sub
Else
' r(.Cells(i, ret(1)).Value) = .Cells(i, ret(1)) & "(" & Ws.Name & ")->" & .Cells(i, "A")
r(Tgt.Value) = Tgt & "(" & Ws.Name & ")->" & .Cells(i, "A")
End If
End If
End If
Next
End With
End If
Next
Me.Range("P2") = "会社名更新と赤整合化"
MsgBox "更新・整合化を完了"
End Sub
Private Sub carryOverProc()
Dim rNames As Range, nameCell As Range, prevDayCell As Range
Dim Ws As Worksheet, Rw As Long, Cl As Long, ClRwPOS(1 To 2)
Dim vtlToday As Date, preWday As Date, preDayPOS
Dim RedCount As Long, RedBirdEye As Long
vtlToday = VerturalToday
preWday = Range("P8").Value
If Me.Range("P11") = Format(vtlToday, "yyyy/mm/dd繰延済") Then
MsgBox "その日の繰延処理は完了しております"
Exit Sub
End If
For Each Ws In ThisWorkbook.Worksheets
If Not Ws Is Me And Ws.Name <> "集計表" Then
With Ws
Set rNames = .Range("A4", .Cells(.Rows.Count, "A").End(xlUp))
For Each nameCell In rNames
ClRwPOS(1) = Application.Match(CLng(vtlToday), .Range("A2:AG2"), 0)
ClRwPOS(2) = nameCell.Row
preDayPOS = Application.Match(CLng(preWday), .Range("A2:AG2"), 0)
If Not IsNumeric(preDayPOS) Then
MsgBox Ws.Name & "の" & vtlToday & "の前営業日がありません。赤NO繰越処理中止"
Exit Sub
End If
With .Cells(ClRwPOS(2), preDayPOS) '前営業日のセル
If .Value <> "" Then
If .Font.Color = vbRed Then
.Copy Ws.Cells(ClRwPOS(2), ClRwPOS(1))
recordLog Array(Now, "繰越し" & Day(preWday) & "→" & Day(vtlToday), Ws.Name, nameCell, .Value)
RedCount = RedCount + 1
End If
End If
End With
Next
End With
End If
Next Ws
Me.Range("P11") = Format(vtlToday, "yyyy/mm/dd繰延済")
'Me.Range("P5").ClearContents
RedBirdEye = Application.CountIf(Range("C9:L20"), "*(*)->*")
If RedBirdEye <> RedCount Then
MsgBox "会社シートの赤番号総数(" & RedCount & ")" & "と全貌表の使用数(" & RedBirdEye & ")が不一致です"
End If
End Sub
Private Function VerturalToday() As Date
VerturalToday = IIf(Range("P5").Value <> "", Range("P5").Value, Date)
End Function
（半平太） 2021/09/15(水) 21:23 (※23:17一部修正しました)
仮想本日を入力すると、その日が当日と思って処理されますので、 その日付を残したまま正常日処理をすることがないようにしてください。
E3セルに仮想本日が残っているかどうか表示される様にはしてありますが、十分な警告にはならないかもです。 (条件付き書式で警告するのもいいかも知れません。工夫してください)
（半平太） 2021/09/15(水) 21:33
前日まで借りっぱなしの状態で、P10セルをダブルクリックしても
【"の前営業日がありません。赤NO繰越処理中止"】の表示が出てしまいます。
例：9/6～9/16現在まで借りてる場合、9/6に駐車番号（10）の入力をしていて、
9/16にP10セルをダブルクリックすると、7,8,9,10,11,13,14,15日に10番の赤文字が並ぶ。
というイメージでした。
あと、連日借りていた最終日に返却処理をすると、最終日は黒文字に変わるのですが
それ以前の同じ駐車番号は赤文字のままになるのですが、これはどうしよもないですよね…？＞＜
最終日が黒文字になって返却したことはわかるので大したことではないんですけど
月末、会社別シートを見た時に借りっぱなしのところがパッと1か月分わかるように色分けをしていたので
合間に赤文字が残っていると、「あれ？ここまだ借りてる？」と思ってしまいそうで…。
（あるとしたら月末から月跨ぎで借りっぱなしの状態か、月末までずっと借りっぱなし〈全部赤文字〉が理想です。）
例：9/13～9/15まで借りていた場合、15日に返却処理をすると13,14,15日の文字が黒くなる。
要望とわがままばかりすみません；＿；
でも、かなりいい物になっていてただただ感動感激しております。
本当に感謝しています！！！
入力間違いや、駐車場の空き状況の把握は断然前よりもわかりやすくなりました！！
素人には難しすぎることを、ここまで作ってくださった半平太さまには死ぬほど感謝しております！
ありがとうございます！！＞＜
（mammie） 2021/09/16(木) 10:16
＞前日まで借りっぱなしの状態で、P10セルをダブルクリックしても ＞【"の前営業日がありません。赤NO繰越処理中止"】の表示が出てしまいます。 ＞ ＞例：9/6～9/16現在まで借りてる場合、9/6に駐車番号（10）の入力をしていて、 ＞9/16にP10セルをダブルクリックすると、7,8,9,10,11,13,14,15日に10番の赤文字が並ぶ。 ＞というイメージでした。
<a社 シート> 行 ___A___ __B__ __C__ __D__ __E__ : : : : __J__ __K__ __L__ __M__ __N__ __O__ __P__ __Q__ __R__ __S__ 1 2021 9 : : : : 2 1日 2日 3日 : : : : 8日 9日 10日 11日 12日 13日 14日 15日 16日 17日 3 利用者 車番 (水) (木) (金) : : : : (水) (木) (金) (土) (日) (月) (火) (水) (木) (金) 4 会田 : : : : 10 10 10 10 10 10
想定としては、前日が上のような状態で、本日(9/16)の朝一でP10セルをダブルクリックした、と言う想定テストですね。
やってみましたけども「繰越完了」のメッセージが出て、a社のシートを見ると、問題なく10(赤）が16日に繰り越されましたけども。
<a社 シート 結果図> 行 __O__ __P__ __Q__ __R__ 1 2 13日 14日 15日 16日 3 (月) (火) (水) (木) 4 10 10 10 10
これ、正しくやりましたか？ ↓ ＞ ３．以下の数式を入力する。 ＞ (1) P8セル =WORKDAY.INTL(IF(P5="",TODAY(),P5),-1,11,P14:P31)
＞あと、連日借りていた最終日に返却処理をすると、最終日は黒文字に変わるのですが ＞それ以前の同じ駐車番号は赤文字のままになるのですが、これはどうしよもないですよね
それ以前の色を全部黒に変えるのは別に難しいことじゃないですが、操作ミスした場合が怖い。
直前のデータは手作業で何とか元に戻せるでしょうが、それ以前の色までは誰も覚えていないですからねぇ。。 そのリスクを負うかどうかです。mammieさんが、負うと言うならやりますけど。
（半平太） 2021/09/16(木) 16:43
＞ これ、正しくやりましたか？
↓ ＞ ＞ ３．以下の数式を入力する。 ＞ ＞ (1) P8セル =WORKDAY.INTL(IF(P5="",TODAY(),P5),-1,11,P14:P31)
やりました。そこには前日の日付が表示されるようになっています。
20社のシートの中に、1日からずっと借りっぱなしの人や、昨日からの人、8日から・・・
など、様々な日付に赤文字の駐車番号が入っていて、今朝の時点（9/17）で返却がない場合は
9/17までの日付のセル（日曜以外）に駐車番号が右にコピーされると思うのですが
【"の前営業日がありません。赤NO繰越処理中止"】しか出ません・・・。
＞それ以前の色を全部黒に変えるのは別に難しいことじゃないですが、操作ミスした場合が怖い。
＞直前のデータは手作業で何とか元に戻せるでしょうが、それ以前の色までは誰も覚えていないですからねぇ。。
＞ そのリスクを負うかどうかです。mammieさんが、負うと言うならやりますけど。
全貌表シートの操作だけで完了するのであまり各社シートを確認しなくてできますもんね。
前日までの色をいちいち見てはいないので、操作ミスを考えると半平太さんのおっしゃる通りかもしれません。
これは手作業で様子見ることにします。
ありがとうございます。
（mammie） 2021/09/17(金) 09:21
この認識が違うかも知れないので念押しです。 ↓ ＞9/17までの日付のセル（日曜以外）に駐車番号が右にコピーされると思うのですが
「前営業日が赤字なら、本日の列にコピーする」です。 表現に微妙な違いがあります。同じ理解ならいいのですが。
ついでですが、月初にこの処理はやらないでください。 前営業日なんて存在しないので。
さて、【"の前営業日がありません。赤NO繰越処理中止"】が出る原因についてです。 R2のデータが日付シリアル値ではないとしか考えられないですが、 それだと9/16当日の処理も出来なかったハズなんで・・不可解。
会社シート及び全貌表シートに無関係なシートが入っていたりしないですか？ 無関係のシートがあったら、2行目に日付なんかあるハズないですからねぇ。。
＞これは手作業で様子見ることにします。 こっちの問題につては、いま対策を練っていますので、少々お待ちを。
（半平太） 2021/09/17(金) 12:23
ありがとうございます＞＜
ものすごく理想的なデータに仕上がっております。。。
半平太さま素敵すぎます。
（mammie） 2021/09/17(金) 13:15
＞私が、集計用にシートを１つ作って、全シートの合計金額が ＞見れる一覧表を作っておいておりました
その一覧表のシート名を教えてください。 全貌表と同じく、対象外の扱いにしますので。
※そのブック内に置いておかないと不便でしょうから。
（半平太） 2021/09/17(金) 15:05
シート名は「集計表」です。
ありがとうございます；＿；
（mammie） 2021/09/17(金) 15:17
＞操作ミスした場合が怖い。 ＞それ以前の色までは誰も覚えていないですからねぇ。。
無料版(?)とは言え、ちょっと不親切だったかも知れないです。
以下の2点を改善します。
１．返却時、履歴に「返却済14～17」とか表示するようにして、 赤→黒に変わったのが「14日から17日」だと分かる様にします。
これなら、過去の色を元に戻す手掛かりにできると思います。
２．会社シートを手修正した場合、全貌表の赤と食違いが出る可能性があります。 そうなると、会社シートと全貌表との整合性を図る機能を盛り込む必要性を感じます。
つまり、質問当初の機能(横にズラーと出す）を全貌表用に作らないと手修正作業が辛すぎます。 その機能は「会社名更新」(P2セル）のダブルクリック時に追加的に実行するようにします。
つまり、「会社名更新と赤整合化」と言うものに変えます。 不整合になるような修正を行ったと認識したら、P2セルをダブルクリックすれば、 会社データの方を優先的に反映させられます。
なお、この機能は何時でも実行可能です。気軽にやってください。 シート間が整合しているのが確信できて不安感が減ります。
コードは、以前のレスに上書きしましたので、全とっかえしてください。 ↓ ＞（半平太） 2021/09/15(水) 21:23 (※23:17一部修正しました)
（半平太） 2021/09/17(金) 16:16
※会社ごとのシートになっておらず当質問への回答とは逸れたものになっています
手順 １．シート定義用のコードを任意のブックで実行（実行後破棄） ２．１でできたブックにユーザーフォームを2つ、標準モジュールを1つ、クラスモジュールを1つ作成 ３．下記コードをそれぞれのモジュールにコピー
各シートの役割
Sheet1:現在の利用状況。A列に値のある行分だけフォームにボタンが現れる。 B～D列に値があるときは利用中となる。間違えて利用登録した場合はこのシートのデータを手動削除。
Sheet2:利用者登録情報。フォームのボタンをクリックしたときに出てくるリストはこのシートのデータを使っている。
シートで直接編集しても良い。多人数一括登録はこの方法で。
ナンバー等が勝手にデータ整形されないようにシート全体に書式設定で「表示形式：文字列」にしてある。
このシートにフィルターをかけることで会社別の利用者登録情報閲覧が可能。
Sheet3のデータを関数で持ってきて右の方の列に表示させるとかいろいろできそうだが今回はピボットテーブル作成練習のため割愛。
Sheet3:利用履歴。フォーム１で使用終了処理をするとこのシートにデータが蓄積される。 当日以外のデータはここに直接入力。自動入力では日付+時刻が記入されているが 手動入力の場合は時刻を記入しなくても差し支えない。 利用履歴以外を書くとピボットテーブル作成時にエラーが発生する。
Sheet4:マクロボタン置き場。それ以上の意味は無い。
Sheet4に2つあるボタン 「管理」：シート定義用コード実行時入力した数値の分だけボタンがあるフォームが現れる。 （Sheet1のA列に羅列。ここを編集するとボタン数やボタンに表示される文字が変わる。） クリックすると登録フォームが現れる。「新規」ボタンで利用者データ登録可能。 登録データはSheet2に蓄積される。Sheet2を直接編集でも可。
「履歴まとめ」：Pivot1、Pivot2の２つシートを作成しSheet3に蓄積されたデータを2つのピボットテーブルに出力する。 1つ目は会社名氏名別の使用回数。 2つ目は会社名氏名別の使用した番号リスト。（1日2回利用すると2つの番号が合計されたものが出てしまうエラーあり）
各フォームの役割
UserForm1:利用登録と使用終了の操作と状況確認ができる。 ボタンの色により「青：空き」「黄色：使用中」「赤：超過（前日以前から使用しているが終了処理未済）」の３つの状態がある。 青の時は利用登録用のUserForm2が開く。 黄色の時は使用終了確認のみ（OK/Cancel）。OKボタンで使用状態解除（→青）＆Sheet3に履歴登録。 赤の時は使用終了/延長/キャンセルをはい/いいえ/cancelで選択。 「はい」ボタンで使用状態解除（→青）＆Sheet3に履歴登録。 「いいえ」ボタンで使用状態継続（→黄色）＆＆Sheet3に履歴登録。 赤の状態で放置されるのは手続未済のみ。利用継続確認の場合延長処理のために黄色に変えること。
UserForm2:利用登録のために使う。 リストボックスはSheet2のデータから。 リスト1から「会社名」(A列)を選び、その次にリスト2から「氏名」を選ぶ。 「氏名」を選ぶと確認ダイアログ（Sheet2のその他のデータも羅列）が出てきてOKボタンで利用登録完了。 「新規」ボタンで新規データ登録ができる。List1を選択済みの場合は最初の会社名はデフォルト表示される。 会社名、氏名どちらかが空白の場合登録キャンセルされる。その他の情報は未入力でも登録可能。 新規登録時の最後の確認ダイアログでOKボタンを押すと利用登録も完了。 ここでキャンセルボタンを押してもSheet2への登録だけはされる。次回からはリストにも現れる。 未入力の情報追加はSheet2で直接入力する。 なお登録情報の重複チェックはしていないので同一データが2つ以上登録できてしまう。 （集計では合計され統一される。同一会社同姓同名の場合名前を分ける等の工夫が必要。） シート定義用コード （InputBoxで台数を問われるので整数を記入。記入した分だけフォームにボタンが作成される）
Sub MakeNewBook()
Dim Cnt As Long
Cnt = Application.InputBox("台数入力", Type:=1)
If Cnt < 1 Then Exit Sub
Dim NewWb As Workbook
Dim Ws1 As Worksheet
Dim Ws2 As Worksheet
Dim Ws3 As Worksheet
Dim Ws4 As Worksheet
Dim TopLeftCell As Range
Set NewWb = Workbooks.Add
With NewWb
Set Ws1 = .Worksheets(1)
Set Ws2 = .Worksheets.Add(after:=Ws1)
Set Ws3 = .Worksheets.Add(after:=Ws2)
Set Ws4 = .Worksheets.Add(after:=Ws3)
ActiveWindow.DisplayGridlines = False
ActiveWindow.DisplayHeadings = False
End With
With Ws1.Cells(1)
.Resize(, 4).Value = Array("No", "開始", "会社名", "氏名")
With .Offset(1)
.Value = 1
.AutoFill Destination:=.Resize(Cnt), Type:=xlFillSeries
End With
End With
Ws2.Cells(1).Resize(, 6).Value = Array("会社名", "氏名", "車種", "ナンバー", "連絡先", "備考")
Ws2.Cells.NumberFormatLocal = "@"
Ws3.Cells(1).Resize(, 5).Value = Array("No.", "会社名", "氏名", "開始", "終了")
With Ws4
With .Cells(3, 3)
With Ws4.Buttons.Add(.Left, .Top, .Offset(, 5).Left - .Left, .Offset(3).Top - .Top)
.Caption = "管理"
.OnAction = NewWb.Name & "!ShowForm"
End With
End With
With .Cells(10, 3)
With Ws4.Buttons.Add(.Left, .Top, .Offset(, 5).Left - .Left, .Offset(3).Top - .Top)
.Caption = "履歴まとめ"
.OnAction = NewWb.Name & "!MakePivotTableSheet"
End With
End With
.Protect UserInterfaceOnly:=True
.EnableSelection = xlNoSelection
End With
End Sub
シート定義用コードここまで。
ユーザーフォーム１用コード
Const TOPROW As Long = 2 'シート１の先頭行設定 Const FORMMARGIN As Long = 12 'ユーザーフォームの余白設定 Const BTNWIDTH As Double = 60 'ボタンの横幅設定 Const BTNHEIGHT As Double = 18 'ボタンの縦幅設定
Dim btn() As Class1
Private Sub UserForm_Initialize()
Dim Sh As Worksheet
Dim lastRow As Long
Dim btnPerRow As Long
Dim i As Long
Set Sh = Sheet1
lastRow = Sh.Cells(Rows.Count, "A").End(xlUp).Row
If lastRow < 2 Then
MsgBox "Error：Sheet1 A列を確認", vbCritical
Exit Sub
End If
ReDim btn(lastRow - TOPROW)
If Sqr(UBound(btn) + 1) <= 4 Then
btnPerRow = 4
Else
btnPerRow = 1 + Int(Sqr(UBound(btn)))
End If
For i = TOPROW To lastRow
Set btn(i - TOPROW) = New Class1
With btn(i - TOPROW)
Set .Button = Me.Controls.Add("Forms.CommandButton.1")
Set .DataRange = Sh.Cells(i, "A").Resize(, 4)
.Width = BTNWIDTH
.Height = BTNHEIGHT
.Left = FORMMARGIN + ((i - TOPROW) Mod btnPerRow) * BTNWIDTH
.Top = FORMMARGIN + ((i - TOPROW) \ btnPerRow) * BTNHEIGHT
End With
Next
With Me
.Width = FORMMARGIN * 2 + .Width - .InsideWidth + BTNWIDTH * WorksheetFunction.Min(lastRow - TOPROW + 1, btnPerRow)
.Height = FORMMARGIN * 2 + .Height - .InsideHeight + BTNHEIGHT * (1 + (lastRow - TOPROW) \ btnPerRow)
End With
End Sub
ユーザーフォーム１用コードここまで。
ユーザーフォーム２用コード
Dim dic As Object Dim WithEvents btn As MSForms.CommandButton Dim WithEvents List1 As MSForms.ListBox Dim WithEvents List2 As MSForms.ListBox
Dim cls As Class1
Dim Sh As Worksheet Dim Index() As Variant
Sub Initial(class_ As Class1)
Dim datRange As Range
Dim var() As Variant
Dim tmp As Variant
Dim i As Long, j As Long
Set dic = CreateObject("Scripting.Dictionary")
Set Sh = Sheet2
Set cls = class_
Set datRange = Intersect(Sh.UsedRange, Sh.UsedRange.Offset(1))
Index = Sh.UsedRange.Rows(1).Cells.Value
If Not datRange Is Nothing Then
var = datRange.Value
For i = LBound(var, 1) To UBound(var, 1)
If Not dic.exists(var(i, 1)) Then
dic.Add var(i, 1), CreateObject("Scripting.Dictionary")
End If
If Not dic(var(i, 1)).exists(var(i, 2)) Then
ReDim tmp(UBound(var, 2) - 2)
For j = LBound(tmp) To UBound(tmp)
tmp(j) = var(i, LBound(var, 2) + j)
Next
dic(var(i, 1)).Add var(i, 2), tmp
End If
Next
End If
Set btn = Me.Controls.Add("Forms.CommandButton.1")
With btn
.Left = 12
.Top = 12
.Width = 80
.Height = 18
.Caption = "新規"
End With
Set List1 = Me.Controls.Add("Forms.Listbox.1")
With List1
.Left = 12
.Top = 40
.Width = 96
.Height = 144
.List = dic.keys
End With
With Me
.Width = 24 + .Width - .InsideWidth + List1.Width
.Height = 48 + .Height - .InsideHeight + List1.Height
.Show
End With
End Sub
Private Sub btn_Click()
If MsgBox("新規登録？", vbYesNo) <> vbYes Then Exit Sub
Dim tmp() As Variant
Dim defaultStr As String
Dim i As Long
ReDim tmp(UBound(Index, 2) - 1)
For i = LBound(Index, 2) To UBound(Index, 2)
If i = 1 And List1.ListIndex > -1 Then
defaultStr = List1.Value
Else
defaultStr = ""
End If
tmp(i - 1) = InputBox(Prompt:=Index(1, i) & "？", Default:=defaultStr)
If StrPtr(tmp(i - 1)) = 0 Then Exit Sub
If i = 2 Then
If Len(Replace(StrConv(tmp(0), vbNarrow), " ", "")) < 1 Or _
Len(Replace(StrConv(tmp(1), vbNarrow), " ", "")) < 1 Then
MsgBox "登録中止"
Exit Sub
End If
End If
Next
Sh.Cells(Rows.Count, "A").End(xlUp).Offset(1).Resize(, UBound(tmp) + 1).Value = tmp
Call SubmitData(tmp)
End Sub
Private Sub List1_Click()
If List1.Value <> "" Then
If List2 Is Nothing Then
Set List2 = Me.Controls.Add("Forms.Listbox.1")
With List2
.Left = 18 + List1.Width
.Top = List1.Top
.Width = 96
.Height = 144
End With
With Me
.Width = 30 + .Width - .InsideWidth + List1.Width + List2.Width
.Height = 48 + .Height - .InsideHeight + WorksheetFunction.Max(List1.Height, List2.Height)
End With
Else
List2.Clear
End If
List2.List = dic(List1.Value).keys
End If
End Sub
Private Sub List2_Click()
If List2.Value <> "" Then
Dim tmp() As Variant
tmp = dic(List1.Value)(List2.Value)
Call SubmitData(tmp)
End If
End Sub
Private Sub SubmitData(data() As Variant)
Dim msg As String
Dim i As Long
msg = Format(Now(), "yyyy/m/d h:mm") & vbCrLf
For i = LBound(data) To UBound(data)
msg = msg & Index(1, i + 1) & ":" & data(i) & vbCrLf
Next
If MsgBox(msg, vbOKCancel) = vbOK Then
With cls
With .DataRange
.Cells(1, 2).Value = Now()
.Cells(1, 3).Value = data(0)
.Cells(1, 4).Value = data(1)
End With
.CaptionChange
.ColorChange
End With
End If
Unload Me
End Sub
ユーザーフォーム２用コードここまで。
標準モジュール用コード
'シート名、テーブル名の設定 Const SHNAME1 As String = "Pivot1" Const SHNAME2 As String = "Pivot2" Const PTNAME1 As String = "myPivotTable1" Const PTNAME2 As String = "myPivotTable2"
Sub ShowForm()
UserForm1.Show
End Sub
Sub MakePivotTableSheet()
Dim PvCache As PivotCache
Dim PvCache2 As PivotCache
Dim PvTable As PivotTable
Dim DataSh As Worksheet
Dim Sh1 As Worksheet
Dim Sh2 As Worksheet
Dim rng As Range
Set DataSh = Sheet3
'DataShにデータが無ければ中止
If DataSh.Cells(Rows.Count, "A").End(xlUp).Row < 2 Then
MsgBox "データ無し"
Exit Sub
End If
'出力シートの準備（無ければつくる）
With ThisWorkbook
On Error Resume Next
Set Sh1 = .Worksheets(SHNAME1)
Set Sh2 = .Worksheets(SHNAME2)
On Error GoTo 0
If Sh1 Is Nothing Then
Set Sh1 = .Worksheets.Add(After:=.Worksheets(.Worksheets.Count))
Sh1.Name = SHNAME1
End If
If Sh2 Is Nothing Then
Set Sh2 = .Worksheets.Add(After:=Sh1)
Sh2.Name = SHNAME2
Else
Sh2.Move After:=Sh1
End If
End With
'ピボットキャッシュ作成
Set PvCache = DataSh.Parent.PivotCaches.Create(SourceType:=xlDatabase, SourceData:=DataSh.UsedRange.Resize(, 5))
'ピボットテーブルその１作成（利用回数）
On Error Resume Next
Set PvTable = Sh1.PivotTables(PTNAME1)
On Error GoTo 0
If PvTable Is Nothing Then
With PvCache.CreatePivotTable(TableDestination:=Sh1.Range("A1"), TableName:=PTNAME1)
.AddDataField .PivotFields(DataSh.Cells(1, 1).Value), "利用回数", xlCount
.PivotFields(DataSh.Cells(1, 2).Value).Orientation = xlRowField
.PivotFields(DataSh.Cells(1, 3).Value).Orientation = xlRowField
With .PivotFields(DataSh.Cells(1, 4).Value)
.Orientation = xlColumnField
.DataRange.Cells(1, 1).Group _
Start:=True, End:=True, _
Periods:=Array(False, False, False, True, False, False, False)
End With
End With
Else
PvTable.ChangePivotCache PvCache
End If
'変数リセット
Set PvTable = Nothing
'ピボットキャッシュ作成（更新の場合ここで再作成しないとエラーが発生する）
Set PvCache = DataSh.Parent.PivotCaches.Create(SourceType:=xlDatabase, SourceData:=DataSh.UsedRange.Resize(, 5))
'ピボットテーブルその２作成（利用番号）
On Error Resume Next
Set PvTable = Sh2.PivotTables(PTNAME2)
On Error GoTo 0
If PvTable Is Nothing Then
With PvCache.CreatePivotTable(TableDestination:=Sh2.Range("A1"), TableName:=PTNAME2)
.AddDataField .PivotFields(DataSh.Cells(1, 1).Value), "利用番号"
With .PivotFields(DataSh.Cells(1, 2).Value)
.Orientation = xlRowField
.Subtotals(1) = False
End With
.PivotFields(DataSh.Cells(1, 3).Value).Orientation = xlRowField
With .PivotFields(DataSh.Cells(1, 4).Value)
.Orientation = xlColumnField
.DataRange.Cells(1, 1).Group _
Start:=True, End:=True, _
Periods:=Array(False, False, False, True, False, False, False)
End With
.ColumnGrand = False
.RowGrand = False
End With
Else
PvTable.ChangePivotCache PvCache
End If
End Sub
標準モジュール用コードここまで。
クラスモジュール用コード
Const A_COLOR As Long = 16777088 '「空き」時のボタン色 Const B_COLOR As Long = 65535 '「使用中」時のボタン色 Const E_COLOR As Long = 255 '「超過」時のボタン色
'コマンドボタン Private WithEvents btn As MSForms.CommandButton
Private DataSheet As Worksheet Private InputRange As Range 'データ入力範囲 '1列目：名称 '2列目：入力時刻 '3列目：会社名 '4列目：氏名
Private Sub Class_Initialize()
'登録データを蓄積するシートを設定
Set DataSheet = Sheet3
End Sub
Private Sub btn_Click()
If btn.BackColor = A_COLOR Then
'「空き」のときは使用者登録フォームを開く
Call UserForm2.Initial(Me)
Else
'「使用中」「超過」のときは使用終了処理確認
Dim DialogBtnStatus As Long
Dim msg As String
Dim NowData As String
Dim buf As VbMsgBoxResult
NowData = Format(Now(), "yyyy/m/d h:mm")
msg = "使用終了？" & vbCrLf & NowData
If btn.BackColor = E_COLOR Then
'「超過」のときは「Yes」「No」「Cancel」の３つボタン、msgに情報追加
DialogBtnStatus = vbYesNoCancel
msg = msg & vbCrLf & vbCrLf & "（はい:使用終了 いいえ:延長）"
Else
'「使用中」のときは「OK」と「Cancel」の２つボタン
DialogBtnStatus = vbOKCancel
End If
buf = MsgBox(msg, DialogBtnStatus)
If buf <> vbCancel Then
Dim var(1 To 1, 1 To 5) As Variant
With InputRange
'履歴に移すデータを登録
var(1, 1) = .Cells(1, 1).Value
var(1, 2) = .Cells(1, 3).Value
var(1, 3) = .Cells(1, 4).Value
var(1, 4) = .Cells(1, 2).Value
var(1, 5) = NowData
If buf = vbNo Then
'Noのときは時刻を現在時刻に更新（延長）
.Cells(1, 2).Value = NowData
Else
'Yesのときは2列目以降をクリア
.Offset(, 1).Resize(, .Columns.Count - 1).ClearContents
End If
'ボタン表示を変更
Call CaptionChange
Call ColorChange
End With
'履歴シートにデータ入力
DataSheet.Cells(Rows.Count, "A").End(xlUp).Offset(1).Resize(, UBound(var, 2)).Value = var
End If
End If
End Sub
Sub CaptionChange()
'ボタンの表示文字を変更する
Dim tmp As String
Dim tmp2 As String
tmp = InputRange(1, 1).Value
tmp2 = InputRange(1, 3).Value
If tmp2 <> "" Then
tmp = tmp & " : " & tmp2
End If
btn.Caption = tmp
End Sub
Sub ColorChange()
'データ2列目の値に応じてボタン色を変更する
Dim buf As Long
Select Case InputRange(1, 2).Value
Case 0: buf = A_COLOR '空白又は0のときは「空き」色
Case Is < Date: buf = E_COLOR '本日の0:00より前のシリアル値の場合は「超過」色
Case Else: buf = B_COLOR 'その他は「使用中」色
End Select
btn.BackColor = buf
End Sub
'以下各種プロパティ設定
Property Set Button(CommandButton_ As MSForms.CommandButton)
Set btn = CommandButton_
End Property
Property Let Width(ByVal Width_ As Double)
btn.Width = Width_
End Property
Property Let Height(ByVal Height_ As Double)
btn.Height = Height_
End Property
Property Let Left(ByVal Left_ As Double)
btn.Left = Left_
End Property
Property Let Top(ByVal Top_ As Double)
btn.Top = Top_
End Property
Property Set DataRange(Range_ As Range)
Set InputRange = Range_
'対応データ範囲を登録時に入力データによりボタンの状態を変更する
Call CaptionChange
Call ColorChange
End Property
Property Get DataRange() As Range
Set DataRange = InputRange
End Property
クラスモジュール用コードここまで。
（めざめるパワー） 2021/09/21(火) 08:40
[ 一覧(最新更新順) ]
YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki.
Modified by kazu.