プロが教えるわが家の防犯対策術!

いつもお世話になっております
下記のコードは某サイトから利用しているものです。
一つ条件をくわえたいのですが
Aさん
Bさん
Cさん
Dさん
がいまして、名前ごとに背景色の色をかえたいのですが、
おしえてくれませんでしょうか

添付ファイルは見やすいよう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

「vba 進捗状況」の質問画像

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

  • うーん・・・

    すみません。
    ・誰(何番目の人?)が何色になるのか?
    Aさん 赤
    Bさん 青
    Cさん みどり
    Dさん 黄色


    ・なぜ『SELECT CASE』を条件としているのか?(ある意味人数分だけ『Case ~』を必要とする事に意味があるのか?)
    できれば SELECT CASE 管理しやすいと思いました。

    ・仮定として『同じ名前の人が2回以上出てくる』事があるのか?
    あります



    おしえてくれませんでしょうか

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

    E-F列が日付ならIf IsDate(.Value) Then
    もしもE列OFFSET(0,-1) D列が If Offset(, -1).Value = "Aさん" Then
    If hiduke >= d1 And hiduke <= d2 Then
    If E列 >= d1 And F列 <= 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

A 回答 (5件)

#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

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

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

例えば、登録者名簿などのシートを作成し 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に反映できるので
変更も容易です。シートは非表示にするなども良いかと、、
    • good
    • 0
この回答へのお礼

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

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

添付忘れました


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

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

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


条件設定 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にした方が良いかもです。
この回答への補足あり
    • good
    • 0
この回答へのお礼

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

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

こんにちは



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

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

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

Select Case 名前
 Case "Aさん"
  色 = vbGreen
 ・・・・・・
 ・・・・・・
みたいな感じでしょうか…
    • good
    • 1
この回答へのお礼

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

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

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



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

例えばColorの配列を作成して任意の色を指定しておく。
出てきた順にColor配列のインデックスを用いて色の塗分けをする。(Countで人数を数えるとか打ち込んだ行番号を補正し利用するなど。)
この回答への補足あり
    • good
    • 0
この回答へのお礼

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

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

お探しのQ&Aが見つからない時は、教えて!gooで質問しましょう!

このQ&Aを見た人はこんなQ&Aも見ています


このQ&Aを見た人がよく見るQ&A

人気Q&Aランキング