いつもお世話になっております
下記のコードは某サイトから利用しているものです。
一つ条件をくわえたいのですが
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
No.4ベストアンサー
- 回答日時:
#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に反映できるので
変更も容易です。シートは非表示にするなども良いかと、、
いつも有難うございます。
なんかいろいろと本当にありがとうございました
うまくいきました。
貴重なお時間を頂きましてありがとうございます。
No.5
- 回答日時:
添付忘れました
上手く行かなかったですか、、、
私はご質問の hiduke As Date hiduke = Range("H5").Offset(0, j).Value が
どの様にして成立しているのか?多分書式設定を行って 01 02・・と表示されているのだろうと想像していますが
hidukeの設定部分も確認してみてください。
No.3
- 回答日時:
こんにちは、横から失礼します。
条件設定 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にした方が良いかもです。
No.2
- 回答日時:
こんにちは
普通に考えると、
>Aさん 赤
>Bさん 青
>Cさん みどり
>Dさん 黄色
の表を(別シートにでも)作成しておいて、これを参照するのが簡単かと。
表を作りたくなければ、直接配列でも連想配列にでも設定しておけばよろしいでしょう。
>できれば SELECT CASE 管理しやすいと思いました。
人数が10人、20人になった場合を考えると、長々としたCASE文のコードをメンテするよりもデータだけの表をメンテするほうが安全で簡便だと思いますけれど。
どうしてもCASE文にしたい場合は、同様のことをCASE文で列挙すれば良いでしょう。
Select Case 名前
Case "Aさん"
色 = vbGreen
・・・・・・
・・・・・・
みたいな感じでしょうか…
No.1
- 回答日時:
ちょっとした疑問ですけど。
・誰(何番目の人?)が何色になるのか?
・なぜ『SELECT CASE』を条件としているのか?(ある意味人数分だけ『Case ~』を必要とする事に意味があるのか?)
・仮定として『同じ名前の人が2回以上出てくる』事があるのか?
例えばColorの配列を作成して任意の色を指定しておく。
出てきた順にColor配列のインデックスを用いて色の塗分けをする。(Countで人数を数えるとか打ち込んだ行番号を補正し利用するなど。)
お探しのQ&Aが見つからない時は、教えて!gooで質問しましょう!
関連するカテゴリからQ&Aを探す
おすすめ情報
- ・漫画をレンタルでお得に読める!
- ・人生のプチ美学を教えてください!!
- ・10秒目をつむったら…
- ・あなたの習慣について教えてください!!
- ・牛、豚、鶏、どれか一つ食べられなくなるとしたら?
- ・【大喜利】【投稿~9/18】 おとぎ話『桃太郎』の知られざるエピソード
- ・街中で見かけて「グッときた人」の思い出
- ・「一気に最後まで読んだ」本、教えて下さい!
- ・幼稚園時代「何組」でしたか?
- ・激凹みから立ち直る方法
- ・1つだけ過去を変えられるとしたら?
- ・【あるあるbot連動企画】あるあるbotに投稿したけど採用されなかったあるある募集
- ・【あるあるbot連動企画】フォロワー20万人のアカウントであなたのあるあるを披露してみませんか?
- ・映画のエンドロール観る派?観ない派?
- ・海外旅行から帰ってきたら、まず何を食べる?
- ・誕生日にもらった意外なもの
- ・天使と悪魔選手権
- ・ちょっと先の未来クイズ第2問
- ・【大喜利】【投稿~9/7】 ロボットの住む世界で流行ってる罰ゲームとは?
- ・推しミネラルウォーターはありますか?
- ・都道府県穴埋めゲーム
- ・この人頭いいなと思ったエピソード
- ・準・究極の選択
デイリーランキングこのカテゴリの人気デイリーQ&Aランキング
-
表にフィルターをかけ、絞った...
-
[エクセル]連続する指定範囲か...
-
array関数で格納した配列の型を...
-
配列がとびとびである場合の書き方
-
Excel オートフィルタのリスト...
-
Excelのセルの色指定をVBAから...
-
配列に画像を格納
-
ExcelのINDEXとMATCH関数でスピ...
-
SUMPRODUCT関数を用いた最小値
-
INDEX(D:D,L3)の意味は?
-
以下のプログラムについて教え...
-
Dictionaryを使い4つの条件の一...
-
エクセルのMEDIAN(中央値...
-
DataSetから、DataTableを取得...
-
エクセルで、絶対値の平均を算...
-
Split関数でLong配列に格納する...
-
VBA 配列に格納した値の平均の...
-
配列のSession格納、及び取得方...
-
【VBA】ユーザーフォーム リス...
-
VB6.0 ファイルの一括読込み
マンスリーランキングこのカテゴリの人気マンスリーQ&Aランキング
-
Excelのセルの色指定をVBAから...
-
エクセルで、絶対値の平均を算...
-
表にフィルターをかけ、絞った...
-
ExcelのINDEXとMATCH関数でスピ...
-
[エクセル]連続する指定範囲か...
-
array関数で格納した配列の型を...
-
配列がとびとびである場合の書き方
-
VBA 配列に格納した値の平均の...
-
DataSetから、DataTableを取得...
-
[VBA]改行入りのセルの値を配列...
-
読み込みで一行おきに配列に格納
-
Excel オートフィルタのリスト...
-
iniファイルのキーと値を取得す...
-
【VBA】ユーザーフォーム リス...
-
Split関数でLong配列に格納する...
-
配列のSession格納、及び取得方...
-
VB6.0 ファイルの一括読込み
-
Dictionaryを使い4つの条件の一...
-
INDEX(D:D,L3)の意味は?
-
SUMPRODUCT関数を用いた最小値
おすすめ情報
すみません。
・誰(何番目の人?)が何色になるのか?
Aさん 赤
Bさん 青
Cさん みどり
Dさん 黄色
・なぜ『SELECT CASE』を条件としているのか?(ある意味人数分だけ『Case ~』を必要とする事に意味があるのか?)
できれば SELECT CASE 管理しやすいと思いました。
・仮定として『同じ名前の人が2回以上出てくる』事があるのか?
あります
おしえてくれませんでしょうか
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
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
ここまでは同じですか
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回にわけました。
これでやるとすべての行に色がついてしまいました。