期日までの日数によって段階的にセルの色を変える機能を実装したい。

前提・実現したいこと

現在作業に使用する機器の校正期日一覧のエクセルにマクロを実装するための作業をしています。
今のところ設定した日数の範囲に入ればセルの色が変わるまではできているのですが
校正期日の30日前、20日前、10日間から当日、期日超過と日数が変わるとセルの色が設定した色に変わるという機能を
実装したいのです、。

条件付きの書式の機能で同じことができることは理解していますがマクロで実現できないか悩んでいます。
解決策をご存じの方がいましたらお知恵をお貸しください。

発生している問題・エラーメッセージ

日数による段階的なセルの色の変更ができない。

該当のソースコード

ExcelVBA
1Option Explicit
2
3Sub Alert()
4    ' 設定シート
5    Dim settingSheet As Worksheet
6    Set settingSheet = Worksheets("設定")
7    
8    ' 対象シート
9    Dim targetSheet As Worksheet
10    Set targetSheet = Worksheets(settingSheet.Cells(1, 2).Value)
11    
12    ' 対象列
13    Dim targetColStr As String
14        targetColStr = settingSheet.Cells(2, 2).Value
15    
16    ' 対象列の最終行を取得
17    Dim targetColLastRow As Long
18        targetColLastRow = targetSheet.Cells(Rows.Count, targetColStr).End(xlUp).Row
19    
20    ' 今日の日付を取得
21    Dim today As Date
22        today = Date
23    
24    'データ開始行を取得
25    Dim dataStartRow As Integer
26        dataStartRow = settingSheet.Cells(3, 2).Value
27    
28    ' 対象列を全件チェック
29    Dim i As Integer ' 行数ループカウンタ
30    Dim v As Variant ' セルからの値受け取り変数
31    
32    Dim alertCount  As Integer ' 期限の過ぎている数
33        alertCount = 0
34    
35    Dim checkCount As Integer ' チェック対象の数
36        checkCount = 0
37    
38    Dim notDateCount As Integer ' 日付以外の数
39        notDateCount = 0
40    
41    Dim targetCell As Range
42        For i = 0 To targetColLastRow - dataStartRow
43    
44        Set targetCell = targetSheet.Columns(targetColStr).Rows(dataStartRow + i)
45        v = targetCell.Value
46
47        If IsDate(v) Then
48            checkCount = checkCount + 1
49            
50            If v + settingSheet.Cells(4, 2).Value <= today Then  'settingSheet.Cellsの値は30で設定
51                alertCount = alertCount + 1
52                targetCell.Font.Color = RGB(255, 255, 255)
53                targetCell.Interior.Color = RGB(255, 0, 0)
54            Else
55                targetCell.Font.Color = RGB(0, 0, 0)
56                targetCell.Interior.Color = RGB(255, 255, 255)               
57            End If
58     
59        Else
60            notDateCount = notDateCount + 1
61            targetCell.Font.Color = RGB(0, 0, 0)
62            targetCell.Interior.Color = RGB(255, 255, 0)
63        End If
64        
65    Next
66    
67   
68    If alertCount > 0 Then
69        MsgBox "期限チェック完了しました。1か月以内に有効期限の切れるものがあります。"
70    Else
71        MsgBox "期限チェック完了しました。1か月以内に有効有効期限切れの項目はありません。"
72    End If
73    
74    
75End Sub
76

補足情報（FW/ツールのバージョンなど）

Excel2016

退会済みユーザー

2021/03/04 04:45

コードを提示する際はマークダウンを使用してください。

momomo1986

2021/03/04 07:12

ご指摘いただきありがとうございます。只でさえ不出来なコードがさらに見にくくなっていました。コードを訂正しましたのでよろしければご指摘お願いします。

tatsu99

2021/03/04 08:20

If v + settingSheet.Cells(4, 2).Value <= today Thenの vが校正期日なのですか？

行動規範の内容に同意します

回答2件

現状独自のユーザー定義変数が多く動作が確認出来ないため状況が再現できません。
その上でif文に問題があると仮定した場合、case文に書き換えると治るかもしれません。

Dim DaysLeft As Integer
'DateDiffで日数差を調べる
'v、todayともにdate型を入れてください。
DaysLeft = DateDiff("d", v, today)

'DaysLeftに入れた日数差の数値で判別
Select Case DaysLeft
    Case Is < 0
        '期日超過
    Case 0 To 10
        '当日から10日前
    Case 11 To 20
    Case 21 To 30
    Case Else
        '上記に当てはらまない
End Select

また、各種変数に正しい値が代入されているか確認してください。

投稿2021/03/04 05:02

退会済みユーザー

総合スコア0

momomo1986

2021/03/04 07:17

解答いただきありがとうございました。私の知識不足で解答いただいたコードとのすり合わせがうまくいきませんでした。勝手な話ではありますが、前回のコードをああなる前の状態のコードに訂正しましたのでよろしければ再度の解答をよろしくお願いいたします。

jinoji

2021/03/04 10:50 編集

If IsDate(v) Then checkCount = checkCount + 1 Select Case DateDiff("d", today, v) Case Is < 0 '期日超過 alertCount = alertCount + 1 targetCell.Font.Color = RGB(255, 255, 255) targetCell.Interior.Color = RGB(0, 0, 0) Case Is <= 10 alertCount = alertCount + 1 targetCell.Font.Color = RGB(255, 255, 255) targetCell.Interior.Color = RGB(255, 0, 0) Case Is <= 20 alertCount = alertCount + 1 targetCell.Font.Color = RGB(255, 255, 255) targetCell.Interior.Color = RGB(255, 153, 0) Case Is <= settingSheet.Cells(4, 2).Value 'settingSheet.Cellsの値は30で設定 alertCount = alertCount + 1 targetCell.Font.Color = RGB(0, 0, 0) targetCell.Interior.Color = RGB(255, 204, 0) Case Else '上記に当てはらまない targetCell.Font.Color = RGB(0, 0, 0) targetCell.Interior.Color = RGB(255, 255, 255) End Select Else notDateCount = notDateCount + 1 targetCell.Font.Color = RGB(0, 0, 0) targetCell.Interior.Color = RGB(255, 255, 0) End If

退会済みユーザー

2021/03/05 00:00

修正に関しては概ねjinojiさんの回答と変わらなかったためそちらを参照してください。

momomo1986

2021/03/05 00:12

msuguru様コメントに応えていただきありがとうございました。 jinoji様がお答えくれましたがありがたく思います。またの機会がございましたらどうぞよろしくお願いいたします。

退会済みユーザー

2021/03/05 00:18

動作してよかったです。複数条件をElseIfで繋げていくと分からなくなってバグを作りがちなのでselect caseへの置き換えは出来ると本当に便利ですよ。 https://excel-ubara.com/excelvba1/EXCELVBA322.html

行動規範の内容に同意します

ベストアンサー

today=Date ?

こんな感じですか。

VBA
1Sub Alert()
2    ' 設定シート
3    Dim settingSheet As Worksheet
4    Set settingSheet = Worksheets("設定")
5
6    ' 対象シート
7    Dim targetSheet As Worksheet
8    Set targetSheet = Worksheets(settingSheet.Cells(1, 2).Value)
9
10    Dim resultSheet As Worksheet
11    Set resultSheet = Worksheets(settingSheet.Cells(8, 2).Value)
12
13    ' 対象列
14    Dim targetColStr As String
15        targetColStr = settingSheet.Cells(2, 2).Value
16
17    ' 対象列の最終行を取得
18    Dim targetColLastRow As Long
19        targetColLastRow = targetSheet.Cells(Rows.Count, targetColStr).End(xlUp).Row
20
21    ' 今日の日付を取得
22    Dim today As Date
23        today = Date
24
25    'データ開始行を取得
26    Dim dataStartRow As Integer
27        dataStartRow = settingSheet.Cells(3, 2).Value
28
29    ' 対象列を全件チェック
30    Dim i As Integer ' 行数ループカウンタ
31    Dim v As Variant ' セルからの値受け取り変数
32
33    Dim alertCount  As Integer ' 期限の過ぎている数
34        alertCount = 0
35
36    Dim checkCount As Integer ' チェック対象の数
37        checkCount = 0
38
39    Dim notDateCount As Integer ' 日付以外の数
40        notDateCount = 0
41
42    Dim targetCell As Range
43    
44    For i = 0 To targetColLastRow - dataStartRow
45
46        Set targetCell = targetSheet.Columns(targetColStr).Rows(dataStartRow + i)
47        v = targetCell.Value
48       
49        With Union(targetCell, targetCell.Offset(, -11))
50
51            If IsDate(v) Then
52                checkCount = checkCount + 1
53                
54                Select Case DateDiff("d", today, v)
55                    Case Is < settingSheet.Cells(7, 2).Value '期日超過
56                        alertCount = alertCount + 1
57                        .Font.Color = RGB(255, 255, 255)
58                        .Interior.Color = RGB(0, 0, 0)
59                    Case Is <= settingSheet.Cells(6, 2).Value
60                        alertCount = alertCount + 1
61                        .Font.Color = RGB(255, 255, 255)
62                        .Interior.Color = RGB(255, 0, 0)
63                    Case Is <= settingSheet.Cells(5, 2).Value
64                        alertCount = alertCount + 1
65                        .Font.Color = RGB(255, 255, 255)
66                        .Interior.Color = RGB(255, 153, 0)
67                    Case Is <= settingSheet.Cells(4, 2).Value 'settingSheet.Cellsの値は30で設定
68                        alertCount = alertCount + 1
69                        .Font.Color = RGB(0, 0, 0)
70                        .Interior.Color = RGB(255, 204, 0)
71                    Case Else
72                        '上記に当てはらまない
73                        .Font.Color = RGB(0, 0, 0)
74                        .Interior.Color = RGB(255, 255, 255)
75                End Select
76    
77            Else
78                notDateCount = notDateCount + 1
79                .Font.Color = RGB(0, 0, 0)
80                .Interior.Color = RGB(255, 255, 0)
81            End If
82        
83        End With
84    
85    Next
86
87   ' 結果シートを更新
88    resultSheet.Cells(3, 19).Value = checkCount
89    resultSheet.Cells(4, 19).Value = alertCount
90    resultSheet.Cells(5, 19).Value = notDateCount
91
92    If alertCount > 0 Then
93        MsgBox "期限チェック完了しました。1か月以内に有効期限の切れるものがあります。"
94    Else
95        MsgBox "期限チェック完了しました。期限切れの項目はありません。"
96    End If
97
98End Sub
99