[[20170408235210]] 『 ExcelのVBA（条件付き書式,日付の今週）』（マリオ） ページの最後に飛ぶ
[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
『 ExcelのVBA（条件付き書式,日付の今週）』（マリオ）
ExcelのVBA（条件付き書式）に関する質問です。 【PC環境：Windows 10(64bit) , Excel 2013(32bit)】
日付が入力されているセル （形式：yyyy/mm/dd , 表示形式："aaa"） に対して、条件付き書式の設定で、
〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓 「指定の値を含むセルだけを書式設定」 →「日付」→「今週」の設定をすると、 今週の日付だけに条件付き書式を設定することが できますが、これをExcelのVBAで記述することは、 できますでしょうか？
下記コードの★箇所、２箇所にコードを記述 したいのです。 「今週」「来週」を決定する式があれば、 ※式でも構いません。 〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓
条件付き書式の設定は、マクロの記録で、 記録が残りません。
「今週」と同様にして、「来週」もExcelのVBA で記述したいです。
条件付き書式には、 「数式を使用して、書式設定するセルを決定」 の項目もありますが、 「今週」「来週」を決定する式があれば、 ※式でも構いません。 式が確立されていれば、ExcelのVBAで、 条件付き書式を設定できます。
================================== ■途中まで作成したExcelのVBAのコード
xlsmファイルにて、 新規の「Sheet1」シートがある状態で、 「Module」に次のコードを記述して、実行すると、 画像のように、2〜4行目に、日付欄を作成します。
'〓〓〓〓〓〓〓〓 Option Explicit
Sub 作成()
Call 日付欄
Call 条件付き書式
End Sub
Sub 削除()
With ThisWorkbook.Sheets("Sheet1").Cells
.Clear: .ColumnWidth = 8.38: .RowHeight = 13.5
End With
End Sub
Private Sub 日付欄()
Dim Date1 As Date, Date2 As Date
Dim c(1 To 12) As Long, n As Long
Dim x As Long, i As Long, m As Long
Dim sc As Long, fc As Long
Date1 = Date - 14 '● Date2 = Date1 + 99 '●
If Date2 <= Date1 Then Exit Sub
n = DateDiff("d", Date1, Date2 + 1)
'-----------------------------------------------
With ThisWorkbook.Sheets("Sheet1") '●
x = .Columns.Count - 4
With .Range("E2:E4").Resize(, x)
.ClearContents '値を削除
.UnMerge 'セル結合の解除
.VerticalAlignment = xlCenter
.HorizontalAlignment = xlCenter
.Font.Name = "游ゴシック"
.Font.Size = 14
End With
.Range("E3").NumberFormatLocal = "d"
.Range("E3").Value = Date1
.Range("E3").Font.Size = 11
.Range("E3").AutoFill _
Destination:=.Range("E3").Resize(, n)
.Range("E4").NumberFormatLocal = "aaa"
.Range("E4").Value = Date1
.Range("E4").Font.Size = 11
.Range("E4").AutoFill _
Destination:=.Range("E4").Resize(, n)
sc = 5 '初期値
For i = 6 To 5 + n 'F列から最終列の次列まで
If Day(.Cells(3, i).Value) = 1 Or i = 5 + n Then
fc = i - 1
m = Month(.Cells(3, fc).Value)
.Cells(2, sc) = m
.Range(.Cells(2, sc), .Cells(2, fc)).Merge
sc = i
End If
Next i
.Cells.Rows.AutoFit
.Cells.Columns.AutoFit
.Range("E1:E4").Resize(, x).ColumnWidth = 2.88
End With
'-----------------------------------------------
MsgBox "処理終了！"
End Sub
Private Sub 条件付き書式()
Dim fc As Long, myRng As Range, strFormula As String
With ThisWorkbook.Sheets("Sheet1") '●
fc = .Cells(4, .Columns.Count).End(xlToLeft).Column
.Cells.FormatConditions.Delete
Set myRng = .Range(.Cells(4, "E"), .Cells(4, fc))
End With
'--- 条件付き書式 -----------------------------
strFormula = "=WEEKDAY(E4)=1" '日曜なら
With myRng.FormatConditions.Add( _
Type:=xlExpression, Formula1:=strFormula)
.Font.Color = RGB(255, 0, 0) '赤（文字色）
.StopIfTrue = False '「条件を満たす場合は停止」
End With
'〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓
'今週なら、背景色を薄い黄色'★
'来週なら、背景色を薄い水色'★
'〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓
strFormula = "=(E4=TODAY())" '本日なら
With myRng.FormatConditions.Add( _
Type:=xlExpression, Formula1:=strFormula)
.Interior.Color = RGB(255, 255, 0) '黄色（背景色）
.StopIfTrue = False '「条件を満たす場合は停止」
End With
'-----------------------------------------------
Set myRng = Nothing
End Sub
'〓〓〓〓〓〓〓〓 ■画像http://imgur.com/WDOpZDr
＜ 使用 Excel：Excel2013、使用 OS：Windows10 ＞
条件付き書式を「今週」で設定して、どんな数式が入れられるのかなぁと思って、
myrng.FormatConditions.Item(1).formula1
を表示させたら、これでした。随分慎重だなぁと言う気がします。 ↓ =AND(TODAY()-ROUNDDOWN(E4,0)<=WEEKDAY(TODAY())-1,ROUNDDOWN(E4,0)-TODAY()<=7-WEEKDAY(TODAY()))
多分、こんなので充分だと思います。 ↓ =TODAY()-WEEKDAY(TODAY())=E4-WEEKDAY(E4)
（半平太） 2017/04/09(日) 00:42 (修正 0:51）
>半平太 さん
回答して頂きまして、ありがとうございます。
>myrng.FormatConditions.Item(1).formula1 あちゃー、手作業で設定した条件付き書式の式を 取得できるのですね♪( ´▽｀)
>多分、こんなので充分だと思います。 =TODAY()-WEEKDAY(TODAY())=E4-WEEKDAY(E4) 上記の式は、今週ですが、 来週、再来週にも応用できますか？
また、下記の『今週』であることを調べる式ですが、 ちんぷんかんぷんです(>_<) もし、分かりましたら 式の解説をして頂けませんでしょうか・ =AND(TODAY()-ROUNDDOWN(E4,0)<=WEEKDAY(TODAY())-1,ROUNDDOWN(E4,0)-TODAY()<=7-WEEKDAY(TODAY())) （マリオ） 2017/04/09(日) 03:36
次で、手作業で設定した条件付き書式の式
を取得してみました。
〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓
Sub 条件付き書式で設定した式を取得()
Dim myRng As Range, i As Long
Set myRng = ThisWorkbook.Sheets("Sheet1").Range("E4")
With myRng.FormatConditions
For i = 1 To .Count
Debug.Print .Item(i).Formula1
Next i
End With
End Sub
〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓
取得した結果です。 '■来週 '=AND(ROUNDDOWN(E4,0)-TODAY()>(7-WEEKDAY(TODAY())),ROUNDDOWN(E4,0)-TODAY()<(15-WEEKDAY(TODAY())))
'■今週 '=AND(TODAY()-ROUNDDOWN(E4,0)<=WEEKDAY(TODAY())-1,ROUNDDOWN(E4,0)-TODAY()<=7-WEEKDAY(TODAY()))
================================== 次のようにコードを書き換えました。 『今週』『来週』『再来週』を追加しました！ 『再来週』は適当に、2箇所、「7」を足しただけですが、 合ってるのかな？
'〓〓〓 Option Explicit
Sub 作成()
Call 日付欄
Call 条件付き書式
End Sub
Sub 削除()
With ThisWorkbook.Sheets("Sheet1").Cells
.Clear: .ColumnWidth = 8.38: .RowHeight = 13.5
End With
End Sub
Private Sub 日付欄()
Dim Date1 As Date, Date2 As Date
Dim c(1 To 12) As Long, n As Long
Dim x As Long, i As Long, m As Long
Dim sc As Long, fc As Long
Date1 = Date - 14 '◆ Date2 = Date1 + 99 '◆
If Date2 <= Date1 Then Exit Sub
n = DateDiff("d", Date1, Date2 + 1)
'-----------------------------------------------
With ThisWorkbook.Sheets("Sheet1") '◆
x = .Columns.Count - 4
With .Range("E2:E4").Resize(, x)
.Clear '一旦、消去
.ColumnWidth = 3.88
End With
With .Range("E3")
.NumberFormatLocal = "d"
.Value = Date1
.Font.Size = 11
.AutoFill Destination:=.Resize(, n)
End With
With .Range("E4")
.NumberFormatLocal = "aaa"
.Value = Date1
.Font.Size = 11
.AutoFill Destination:=.Resize(, n)
End With
sc = 5 '初期値
For i = 6 To 5 + n 'F列から最終列の次列まで
If Day(.Cells(3, i).Value) = 1 Or i = 5 + n Then
fc = i - 1
m = Month(.Cells(3, fc).Value)
.Cells(2, sc) = m
.Range(.Cells(2, sc), .Cells(2, fc)).Merge
sc = i
End If
Next i
With .Range("E2:E4").Resize(, n)
.Borders.LineStyle = xlContinuous
.VerticalAlignment = xlCenter
.HorizontalAlignment = xlCenter
.Font.Name = "游ゴシック"
.Font.Size = 14
.Rows.AutoFit
End With
End With
'-----------------------------------------------
MsgBox "処理終了！"
End Sub
Private Sub 条件付き書式()
Dim fc As Long, myRng As Range, strFormula As String
With ThisWorkbook.Sheets("Sheet1") '◆
fc = .Cells(4, .Columns.Count).End(xlToLeft).Column
.Cells.FormatConditions.Delete
Set myRng = .Range(.Cells(4, "E"), .Cells(4, fc))
End With
'--- 条件付き書式 -----------------------------
strFormula = "=WEEKDAY(E4)=7" '土曜なら
With myRng.FormatConditions.Add( _
Type:=xlExpression, Formula1:=strFormula)
.Font.Color = RGB(51, 153, 255) '青（文字色）
.StopIfTrue = False '「条件を満たす場合は停止」
End With
strFormula = "=WEEKDAY(E4)=1" '日曜なら
With myRng.FormatConditions.Add( _
Type:=xlExpression, Formula1:=strFormula)
.Font.Color = RGB(255, 0, 0) '赤（文字色）
.StopIfTrue = False '「条件を満たす場合は停止」
End With
strFormula = "=(E4=TODAY())" '本日なら
With myRng.FormatConditions.Add( _
Type:=xlExpression, Formula1:=strFormula)
.Interior.Color = RGB(255, 255, 0) '黄色（背景色）
.StopIfTrue = False '「条件を満たす場合は停止」
End With
'〓〓〓〓〓〓〓〓〓〓〓〓
strFormula = "=AND(TODAY()-ROUNDDOWN(E4,0)<=WEEKDAY(TODAY())-1,ROUNDDOWN(E4,0)-TODAY()<=7-WEEKDAY(TODAY()))" '今週なら
With myRng.FormatConditions.Add( _
Type:=xlExpression, Formula1:=strFormula)
.Interior.Color = RGB(255, 255, 204) '薄い黄色（背景色）
.StopIfTrue = False '「条件を満たす場合は停止」
End With
strFormula = "=AND(ROUNDDOWN(E4,0)-TODAY()>(7-WEEKDAY(TODAY())),ROUNDDOWN(E4,0)-TODAY()<(15-WEEKDAY(TODAY())))" '来週なら
With myRng.FormatConditions.Add( _
Type:=xlExpression, Formula1:=strFormula)
.Interior.Color = RGB(204, 255, 255) '薄い水色（背景色）
.StopIfTrue = False '「条件を満たす場合は停止」
End With
strFormula = "=AND(ROUNDDOWN(E4,0)-TODAY()>(14-WEEKDAY(TODAY())),ROUNDDOWN(E4,0)-TODAY()<(22-WEEKDAY(TODAY())))" '再来週なら
With myRng.FormatConditions.Add( _
Type:=xlExpression, Formula1:=strFormula)
.Interior.Color = RGB(255, 204, 255) 'ピンク色（背景色）
.StopIfTrue = False '「条件を満たす場合は停止」
End With
'〓〓〓〓〓〓〓〓〓〓〓〓
'-----------------------------------------------
Set myRng = Nothing
End Sub
'〓〓〓
（マリオ） 2017/04/09(日) 03:37
＞ 式の解説をして頂けませんでしょうか ＞ =AND(TODAY()-ROUNDDOWN(E4,0)<=WEEKDAY(TODAY())-1,ROUNDDOWN(E4,0)-TODAY()<=7-WEEKDAY(TODAY()))
多分、E4セルに入っっている値が時刻含みでも対応できる様に作ったのだと思います。 ※普通は、INT()を使うと思うんですがねぇ。
理解し易くするために ROUNDDOWN() を省略してみると・・
=AND(TODAY()-E4<=WEEKDAY(TODAY())-1,E4-TODAY()<=7-WEEKDAY(TODAY()))
第一引数の意味 : E4が今日以前で、今週の日付だとすると、 日数差は、今日が日曜なら0日以内(日曜以降）→今日の曜日番号 - 1（1-1=0）以下 今日が月曜なら1日以内(日曜以降）→今日の曜日番号 - 1 (2-1=1) 以下 ： ： 今日が土曜なら6日以内(日曜以降) →今日の曜日番号 - 1 (7-1=6) 以下
ただ、この数式だけだと、E4に未来日が入ってくると、日数差は全てマイナスになるので、全部真になってしまう。
第二引数では、逆にE4が未来日の場合のチェックを行う。そして、互いに上限・下限をカバーする。
＞ 取得した結果です。 ＞ '■来週 ＞ '=AND(ROUNDDOWN(E4,0)-TODAY()>(7-WEEKDAY(TODAY())),ROUNDDOWN(E4,0)-TODAY()<(15-WEEKDAY(TODAY()))) ↑ ↑ ↑ ↑ ここの括弧は要らないと思います 今週の数式と統一感が無いですね。
私の考え方(※）でやるなら 今週 =TODAY() -WEEKDAY(TODAY())=INT(E4)-WEEKDAY(E4) 来週 =TODAY()+7 -WEEKDAY(TODAY())=INT(E4)-WEEKDAY(E4) 再来週 =TODAY()+14-WEEKDAY(TODAY())=INT(E4)-WEEKDAY(E4)
※考え方は、「TODAYの先週土曜日」と「E4の先週土曜日」が同じなら、同週である。
（半平太） 2017/04/09(日) 10:58
>半平太 様
返信遅れてしまい、すいませんm(__)m
>※普通は、INT()を使うと思うんですがねぇ。
例えば、E4=『2017/04/12 20:35:32』だとしたら、 ROUNDDOWN(E4,0)で、 『2017/04/12 00:00:00』に変換しているのですね。 日付のシリアル値は、正の数字なので、 ★ROUNDDOWN(E4,0)は、★INT(E4)と書けばよいのに ということですね。
======================= >日数差は、今日が日曜なら0日以内(日曜以降）→今日の曜日番号 - 1（1-1=0）以下 >…… >そして、互いに上限・下限をカバーする。
何度も読み返して、理解できました。ん〜むずかしい。
======================= >■来週 >ここの括弧は要らないと思います アドバイス、ありがとうございます。
======================= >※考え方は、「TODAYの先週土曜日」と「E4の先週土曜日」が同じなら、 同週である。
なかなか、思いつけない式ですね(^^♪
脱帽です。何度も見てると、この式の方が理解しやすいですね。
（マリオ） 2017/04/12(水) 21:41
コメント返信：
[ 一覧(最新更新順) ]
YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki.
Modified by kazu.