ｖｂａ 進捗状況

いつもお世話になっております
下記のｺｰﾄﾞは某サイトから利用しているものです。
一つ条件をくわえたいのですが
Ａさん
Ｂさん
Ｃさん
Ｄさん
がいまして、名前ごとに背景色の色をかえたいのですが、
おしえてくれませんでしょうか

添付ファイルは見やすいよう8/12まででくぎりました。
8/31まであります。

SELECT CASE　でお願いいたします。


Private Sub Worksheet_Change(ByVal Target As Range)
Dim i, j As Long
i = Target.Row
j = Target.Column

If i > 4 Then
If j = 6 Or j = 7 Then
Call schedule_update(i)
End If
End If
End Sub



標準モジュール
Dim d1 As Date, d2 As Date, hiduke As Date
Dim j As Long
Dim y As String, m As String, d As String
Dim tantou As String

'Application.ScreenUpdating = False
If Range("E" & i).Value = "" Or Range("F" & i).Value = "" Then
Exit Sub
End If

d1 = Range("E" & i).Value
d2 = Range("F" & i).Value
j = Range("H5").End(xlToRight).Column

For j = 0 To j - 7

'hidukeに格納

hiduke = Range("H5").Offset(0, j).Value

'一度、背景を白に戻す
If Range("H" & i).Offset(0, j).Interior.ColorIndex <> 15 Then
Range("H" & i).Offset(0, j).Interior.ColorIndex = xlNone
End If

'予定に反映を入れる
If hiduke >= d1 And hiduke <= d2 Then
If Range("H" & i).Offset(0, j).Interior.ColorIndex <> 15 Then
Range("H" & i).Offset(0, j).Interior.Color = vbGreen
End If
End If

質問者からの補足コメント

• 

  すみません。
  ・誰（何番目の人？）が何色になるのか？
  Ａさん　赤
  Ｂさん　青
  Ｃさん　みどり
  Ｄさん　黄色
  
  
  ・なぜ『SELECT CASE』を条件としているのか？（ある意味人数分だけ『Case ~』を必要とする事に意味があるのか？）
  できれば SELECT CASE　管理しやすいと思いました。
  
  ・仮定として『同じ名前の人が２回以上出てくる』事があるのか？
  あります
  
  
  
  おしえてくれませんでしょうか

  No.1の回答に寄せられた補足コメントです。 補足日時：2020/08/14 11:23

• 

  Ｅ-Ｆ列が日付ならIf IsDate(.Value) Then
  もしもＥ列OFFSET(0,-1) D列が If Offset(, -1).Value = "Aさん" Then
  If hiduke >= d1 And hiduke <= d2 Then
  If Ｅ列　>= d1 And Ｆ列 <= d2 Then　　ここからわかりません
  Case "E", "F"
  If IsDate(.Value) Then
  If Offset(, -1).Value = "Aさん" Then
  If hiduke >= d1 And hiduke <= d2 Then
  If Range("H" & i).Offset(0, j).Interior.ColorIndex <> 15 Then
  Range("H" & i).Offset(0, j).Interior.Color = vbGreen

    補足日時：2020/08/14 11:36

• Sub schedule_update(i)
  Dim colr As Double
  Dim d1 As Date, d2 As Date, hiduke As Date
  Dim j As Long
  Dim y As String, m As String, d As String
  Dim tantou As String
  If Range("E" & i).Value = "" Or Range("F" & i).Value = "" Then
  Exit Sub
  End If
  d1 = Range("E" & i).Value
  d2 = Range("F" & i).Value
  j = Range("H5").End(xlToRight).Column
  For j = 0 To j - 7
  hiduke = Range("H5").Offset(0, j).Value
  ここまでは同じですか

  No.3の回答に寄せられた補足コメントです。 補足日時：2020/08/14 14:41

• Select Case Cells(i, "D").Value
  Case "Aさん"
  colr = vbRed
  If Range("H" & i).Offset(0, j).Interior.ColorIndex <> 15 Then
  Range("H" & i).Offset(0, j).Interior.Color = colr
  End If
  Case "Bさん"
  colr = vbBlue
  If Range("H" & i).Offset(0, j).Interior.ColorIndex <> 15 Then
  Range("H" & i).Offset(0, j).Interior.Color = colr
  End If
  End Select
  Next
  End Sub
  文字数の制限のため2回にわけました。
  これでやるとすべての行に色がついてしまいました。

    補足日時：2020/08/14 14:44

No.1 回答者： めぐみん_ 回答日時： 2020/08/14 10:55

ちょっとした疑問ですけど。

・誰（何番目の人？）が何色になるのか？
・なぜ『SELECT CASE』を条件としているのか？（ある意味人数分だけ『Case ~』を必要とする事に意味があるのか？）
・仮定として『同じ名前の人が２回以上出てくる』事があるのか？

例えばColorの配列を作成して任意の色を指定しておく。
出てきた順にColor配列のインデックスを用いて色の塗分けをする。（Countで人数を数えるとか打ち込んだ行番号を補正し利用するなど。）

この回答へのお礼

いつも有難うございます。
今までやりましたがうまくいきませんでした。
ありがとうございました。

お礼日時：2020/08/14 20:15

No.2 回答者： fujillin 回答日時： 2020/08/14 13:56

こんにちは

普通に考えると、
＞Ａさん　赤
＞Ｂさん　青
＞Ｃさん　みどり
＞Ｄさん　黄色
の表を（別シートにでも）作成しておいて、これを参照するのが簡単かと。
表を作りたくなければ、直接配列でも連想配列にでも設定しておけばよろしいでしょう。

＞できれば SELECT CASE　管理しやすいと思いました。
人数が10人、20人になった場合を考えると、長々としたCASE文のコードをメンテするよりもデータだけの表をメンテするほうが安全で簡便だと思いますけれど。

どうしてもCASE文にしたい場合は、同様のことをCASE文で列挙すれば良いでしょう。

Select Case 名前
　Case "Aさん"
　　色 = vbGreen
　・・・・・・
　・・・・・・
みたいな感じでしょうか…

この回答へのお礼

いつも有難うございます。
今までやりましたがうまくいきませんでした。
ありがとうございました。

お礼日時：2020/08/14 20:15

No.3 回答者： Qchan1962 回答日時： 2020/08/14 14:15

こんにちは、横から失礼します。

条件設定　hiduke = Range("H5").Offset(0, j).Valueに問題が無いとして

条件で色分けする場合、Call schedule_update(i)　で
schedule_update　側にi （行№）が渡されているので

例えば
Sub schedule_update(i)
・
Dim colr As Double

　　　　Select Case Cells(i, "D").Value 'として変数colrにカラー定数を入れます。
　　　　Case "Aさん"
　　　　　　colr = vbRed
　　　　Case "Bさん"
　　　　　　colr = vbBlue
　　　　Case "Cさん"
　　　　　　colr = vbGreen
　　　　Case "Dさん"
　　　　　　colr = vbYellow
　　　　End Select
・
・
'予定に反映を入れる

　　　　　　　　If Range("H" & i).Offset(0, j).Interior.ColorIndex <> 15 Then
　　　　　　　　　　Range("H" & i).Offset(0, j).Interior.Color = colr
　　　　　　　　End If

のような感じかと、ちなみに　iは、Variant型になっていますのでLongにした方が良いかもです。

この回答へのお礼

いつも有難うございます。
今までやりましたがうまくいきませんでした。
ありがとうございました。

お礼日時：2020/08/14 20:15

No.4 ベストアンサー 回答者： Qchan1962 回答日時： 2020/08/14 20:40

#3です

Range("H" & i).Offset(0, j).Interior.Color = colrはループ内に入れないとダメかと
また、hidukeの設定が出来ない場合　すべての行に色が付く可能性がありますね。

下記は
hiduke の判定を手元の表組みで暫定的に設定して

Sub schedule_update(i As Long)
Dim d1 As Date, d2 As Date, hiduke As Date
Dim j As Long, colr As Double
Dim y As String, m As String, d As String
Dim tantou As String, buf
'Application.ScreenUpdating = False
If Range("E" & i).Value = "" Or Range("F" & i).Value = "" Then
Exit Sub
End If

d1 = Range("E" & i).Value
d2 = Range("F" & i).Value
j = Range("H5").End(xlToRight).Column

Select Case Cells(i, "D").Value
Case "Aさん"
colr = vbRed
Case "Bさん"
colr = vbBlue
Case "Cさん"
colr = vbGreen
Case "Dさん"
colr = vbYellow
End Select

For j = 0 To j - 7
'hidukeに格納
buf = Range("F4") & Range("G4") & Range("H5").Offset(0, j)
’注Range("F4")には　2020　 Range("G4")には　'08 Range("H5")~は　’02、、、、により下記のhidukeを暫定で設定しています
If Len(buf) = 8 Then
hiduke = Format(buf, "@@@@/@@/@@")
'一度、背景を白に戻す
If Range("H" & i).Offset(0, j).Interior.ColorIndex <> 15 Then
Range("H" & i).Offset(0, j).Interior.ColorIndex = xlNone
End If
'予定に反映を入れる
If hiduke >= d1 And hiduke <= d2 Then
If Range("H" & i).Offset(0, j).Interior.ColorIndex <> 15 Then
Range("H" & i).Offset(0, j).Interior.Color = colr
End If
End If
End If
Next

End Sub

として検証してみましたが上手く行くようですが。。

追記
＃２さんのアドバイスにあるようにメンテナンス性などを考慮する必要があるように思います。

例えば、登録者名簿などのシートを作成し　A列　ID　とし一意の№　+　背景色を付けたセル
B列名前とした場合、添付図のような感じの場合
シートモジュールは変更なしで
標準モジュールに

Sub schedule_update(i As Long)
Dim d1 As Date, d2 As Date, hiduke As Date
Dim j As Long, colr As Double
Dim y As String, m As String, d As String
Dim tantou As String
Dim Trg As Range
　　'Application.ScreenUpdating = False
　　If Range("E" & i).Value = "" Or Range("F" & i).Value = "" Then
　　　　Exit Sub
　　End If

　　d1 = Range("E" & i).Value
　　d2 = Range("F" & i).Value
　　j = Range("H5").End(xlToRight).Column

　　Set Trg = Sheets("登録者名簿").Range("B2:B100").Find(What:=Cells(i, "D").Value, LookAt:=xlPart)
　　colr = Trg.Offset(, -1).Interior.Color
　　For j = 0 To j - 7

　　'hidukeに格納　
　　　　　　hiduke = Range("H5").Offset(0, j).Value

　　'一度、背景を白に戻す
　　　　　　If Range("H" & i).Offset(0, j).Interior.ColorIndex <> 15 Then
　　　　　　　　Range("H" & i).Offset(0, j).Interior.ColorIndex = xlNone
　　　　　　End If
　　'予定に反映を入れる
　　　　　　If hiduke >= d1 And hiduke <= d2 Then
　　　　　　　　If Range("H" & i).Offset(0, j).Interior.ColorIndex <> 15 Then
　　　　　　　　　　Range("H" & i).Offset(0, j).Interior.Color = colr
　　　　　　　　End If
　　　　　　End If
　　　　End If
　　Next
End Sub

ご質問のhiduke = Range("H5").Offset(0, j).Valueに問題がない場合です
この書き方で処理をすると登録者名簿シートの状態をVBAに反映できるので
変更も容易です。シートは非表示にするなども良いかと、、

この回答へのお礼

いつも有難うございます。
なんかいろいろと本当にありがとうございました
うまくいきました。
貴重なお時間を頂きましてありがとうございます。

お礼日時：2020/08/14 22:08

No.5 回答者： Qchan1962 回答日時： 2020/08/14 20:47

添付忘れました

上手く行かなかったですか、、、

私はご質問の　hiduke As Date　　hiduke = Range("H5").Offset(0, j).Value　が
どの様にして成立しているのか？多分書式設定を行って　01　02・・と表示されているのだろうと想像していますが
hidukeの設定部分も確認してみてください。