Excel リストの選択回数のカウントアップ

質問

こんにちは。Excelでのカウントアップについての質問です。
以前こちらで質問させて頂きましたが問題が未だ解決しておりませんので再度ご質問させて頂きます。
入力規則でドロップダウンリストを作成しておりそちらで選択した項目の選択回数を別Sheetのセルにカウントアップさせて行きたいのですが、どなたか良い方法がございましたら御教授願います。
内容的にはシフト管理表を作っております。その中で当日の出勤者の氏名が先ずSheet1のB16以下のセルに入って来ます。（最大50名程度）
その為毎日氏名のセルに入る人の名前は入れ替わり、空欄のセルが間に入る事はありません。
またその一つ右側のC16以下のセルに人数分のリストを出せる様にしておりB列のセルに挙がった氏名の内容に応じてリストの内容が変わる形となっております。
そしてSheet2にリストの元となる情報を入れておりD3に氏名D4以下にリストの内容という形にしております。
そして2人目のDataはG3に氏名、G4以下にリスト内容という形で各自2列分のセルを空けて横方向に展開して作成しております。
その為、実質はSheet2の3行目の氏名と4行目以下の内容がSheet1のB列とC列で両方の条件が合致する場合にSheet2の4行目以下の内容の右側に選択回数をカウントアップして行く形を理想としております。
判り辛い説明ですが、マクロや関数等で対応可能であれば御教授願えませんでしょうか？
以上、長文になりましたが宜しくお願い申し上げます。

回答No.3

n_na_tto · ベストアンサー

おそらく1ヶ所だけ.Offset(1)を省けばうまくいくと思います。
↓このコードもご確認ください。

Private Sub Worksheet_Change(ByVal Target As Range)
　'Sheet1のC16:C65が変化したときだけに限定
　If Intersect(Target, Range("C16:C65")) Is Nothing Then Exit Sub
　If Len(Target.Text) = 0 Then Exit Sub
Dim mySht As Worksheet
Dim valB As String, valC As Variant
Dim myRng1 As Range, myRng2 As Range, r As Range
　　Set mySht = Worksheets("Sheet2")
　With Target
　　valB = .Offset(, -1).Value '左隣B列の氏名
　　valC = .Value 'Sheet1のC列の値
　End With
　'Sheet1のC列の値をSheet2のD3の横方向から探す
　　Set myRng1 = mySht.Range("D3").Resize(, 140) '70人分
　　Set r = myRng1.Find(valB, LookIn:=xlValues)
　　If r Is Nothing Then GoTo Err_1
　'Sheet1のB列の値をSheet2の上で見つかったセルの下方向から探す
　　Set myRng2 = r.Resize(50) '50件分
　　Set r = myRng2.Find(valC, LookIn:=xlValues)
　　If r Is Nothing Then GoTo Err_2
　With r.Offset(, 1) '見つかったSheet2のセルの右隣の..
　　.Value = .Value + 1 'カウントをひとつ増やす
　End With
　Exit Sub
Err_1:
　MsgBox "氏名を確認してください。"
　Exit Sub
Err_2:
　MsgBox "リストから選んでください。"
End Sub

お礼

度々の御回答、誠に有難うございました。
完璧に理想通りの形で動いてくれました。
本当に助かりました。
ここ1週間この問題がクリア出来ずに非常に困っておりましたので本当に嬉しいです。
御丁寧且つ御親切にお教え下さり誠に有難うございました。

回答No.2

n_na_tto

構成をチェックしてください。
おそらく、ずれていると思います。
↓こんな感じだと思って回答しました。

Sheet1
＿＿＿_B＿＿_C_
15＿氏名＿内容_
16＿あ▼＿_あ1▼
17＿い▼＿_い4▼
18＿う▼＿_う3▼

Sheet2
＿＿_D＿_E＿＿G＿H＿＿J＿K_
3＿_あ＿＿＿_い＿＿＿う＿＿
4＿あ1＿_5＿い1＿5＿う1＿1_
5＿あ2＿＿＿い2＿1＿う2＿3_
6＿あ3＿_5＿い3＿＿_う3＿1_
7＿あ4＿＿＿い4＿1＿う4＿＿
8＿あ5＿10＿い5＿＿_う5＿1_

お礼

大変申し訳ございません。
こちらの説明が分かり辛かったですね。
ご理解頂いて本当に有難うございました。

回答No.1

n_na_tto

マクロなら
シートモジュール[Sheet1(Sheet1)みたいのをダブルクリック]に

Private Sub Worksheet_Change(ByVal Target As Range)
　'Sheet1のC16:C65が変化したときだけに限定
　If Intersect(Target, Range("C16:C65")) Is Nothing Then Exit Sub
　If Len(Target.Text) = 0 Then Exit Sub
Dim mySht As Worksheet
Dim valB As String, valC As Variant
Dim myRng1 As Range, myRng2 As Range, r As Range
　　Set mySht = Worksheets("Sheet2")
　With Target
　　valB = .Offset(, -1).Value '左隣B列の氏名
　　valC = .Value 'Sheet1のC列の値
　End With
　'Sheet1のC列の値をSheet2のD3の横方向から探す
　　Set myRng1 = mySht.Range("D3").Resize(, 140) '70人分
　　Set r = myRng1.Find(valB, LookIn:=xlValues)
　　If r Is Nothing Then GoTo Err_1
　'Sheet1のB列の値をSheet2の上で見つかったセルの下方向から探す
　　Set myRng2 = r.Offset(1).Resize(50) '50件分
　　Set r = myRng2.Find(valC, LookIn:=xlValues)
　　If r Is Nothing Then GoTo Err_2
　With r.Offset(, 1) '見つかったSheet2のセルの右隣の..
　　.Value = .Value + 1 'カウントをひとつ増やす
　End With
　Exit Sub
Err_1:
　MsgBox "氏名を確認してください。"
　Exit Sub
Err_2:
　MsgBox "リストから選んでください。"
End Sub

お礼

ご連絡が大変遅くなり申し訳ございません。
下記のご回答、有難うございました。
ほぼ理想通りの形で出来ました。
凄いですね。
ただSheet2のD4をはじめ4行目に入れている項目についてはカウントしてくれません。5行目以下の項目はきちんとカウントしてくれてます。
申し訳ございませんが4行目もカウント出来る様に修正は可能でしょうか？
こちらの設定に問題があるのかも知れませんが何故4行目だけがカウントされないのか全く見当がつきませんので・・・。
申し訳ございませんが御教授頂けないでしょうか？
以上、宜しくお願い申し上げます。