[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
『EXCELのマクロで本日までの経過月数でセルに着色をしたい』（ajiponpon）
K・M・O・Q・S列に日付を入力していまして
入力日付から本日が1年以上経過しているセルに赤、 入力日付から本日があと1ヶ月以内で1年の場合は橙、 入力日付から本日があと2ヶ月で以内1年の場合は黄、 入力日付から本日があと3ヶ月で以内1年の場合は黄緑 上記をファイルを開いた時に自動で行う
と設定したいのですが、何分マクロを勉強しはじめたばかりのよちよち状態で 一通り書いてもらったものを少しだけイジるか、自動記録でしか使えない状態です…。
別のところでヒントとして１年以上のものを赤くする下記を頂きました
Sub xxx()
Dim sh As Range
Dim s1 As Date, s2 As Date
For Each sh In Range("a1:a10")
s1 = sh.Value
s2 = DateSerial(Year(Date) - 1, Month(Date), Day(Date))
If s2 > s1 Then sh.Interior.ColorIndex = 3
Next
End Sub
それ以上のヒントがいただけず… これをそれぞれの列で行うにはどう書けばいいのでしょうか？ （UNIONを使えばいいとの事ですがそれが分からず）
条件付書式だと3つまでしか設定ができず困っております。 どなたか詳しい方、教えていただけないでしょうか？ どうぞ宜しくお願い致します。
[エクセルのバージョン]Excel2003 [OSのバージョン]WindowsXP
再検索で教えていただいて有難う御座います。
しかし参考に自分で少し書き換えたのですが分からない部分が出てきまして… １．Y1にTODAY関数で当日の年月日を表示した。 ２. とりあえず1年経過したものだけを試してみようと次のように書き換えました。
でも何も変化がありません…何が間違っているのでしょうか…？ (ajiponpon)
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
Dim iro As Integer
Dim MyStr As String
Dim MyDate As Date
With Target
If .Count > 1 Then Exit Sub
If Application.Intersect(.Cells, Range("K:S")) Is Nothing Then Exit Sub
'~~~~~~~~~~~ ←ここに反映させたい範囲を入力
MyStr = .Value
End With
With CreateObject("VBScript.RegEXP")
.Pattern = "^(\d{4})/(\d{2})/(\d{2})$"
If .test(MyStr) And IsDate(MyStr) Then
MyDate = DateValue(Range("Y1").Value)
Select Case DateValue(MyStr)
Case MyDate To DateSerial(Year(MyDate) - 1, Month(MyDate), 0)
iro = 3
End Select
Target.Interior.ColorIndex = iro
End If
End With
End Sub
※追記：色々な過去ログを遡って見ていましたら？と思う事がありましたので書きます。
セルの日付表記は書式設定の日付でH19.2.1をいう風になっていますが
これと
.Pattern = "^(\d{4})/(\d{2})/(\d{2})$" の部分が何か関係していて何も変化がないのでしょうか…？
ん？マクロはよく分かりませんが、
Range("K:S")→Range("K:K,M:M,O:O,Q:Q,S:S")
としたら？（dack）
リンク先の下の方にもあるように
Case MyDate To DateSerial(Year(MyDate) - 1, Month(MyDate), 0)
は、
「To」の前後の大小関係を考慮しなければなりません。
「To」の前が小さい値で、後が大きい値になるようにします。
Case DateSerial(Year(MyDate) - 1, Month(MyDate), 0) To MyDate
でもこれは、「入力日付から本日が1年以上経過しているセルに赤」の条件にはなりません。 条件を直すと
Case Is <= DateSerial(Year(MyDate) - 1, Month(MyDate), Day(MyDate))
となります。うるう年の考慮はないので上の式では本日が2/29の場合は、1年前が3/1となります。 この辺りをどうするかは決め事でしょうか。
色が変わる条件は今のコードに条件を追加していけば確認できると思います。 「上記をファイルを開いた時に自動で行う」の部分は多少条件以外のところを変更する必要があります。
ちなみに、今のコードの仕様はK・M・O・Q・S列に日付を入力したときにしか色が変わりません。 本日の日付が変わっても、既に入力済みの日付の色が変わるものではありません。 また、複数のセルの日付を同時に入力(変更)しても色は変わりません。
> .Pattern = "^(\d{4})/(\d{2})/(\d{2})$" の部分が何か関係していて何も変化がないのでしょうか…？
日付の書式設定を変更して確認しましたが、書式設定の影響を受けていませんでした。
見た目の「H19.3.15」も「平成19年3月15日」も「2008/3/15」も「2008/03/15」も
MyStr = .Value
の段階で、MyStrの値は「2008/03/15」となっていました。
（やっちん）
'========================================================================
Private Sub Worksheet_Change(ByVal Target As Range)
Dim rng As Range
Dim crng As Range
Dim Mnum As Long
Dim ans As Variant
Dim colorarray As Variant
colorarray = [{-3,43;-2,6;-1,46;0,3}]
With Target
Set rng = Application.Intersect(.Cells, Range("K:K,M:M,O:O,Q:Q,S:S"))
On Error Resume Next
For Each crng In rng
Err.Clear
crng.Interior.ColorIndex = False
If IsDate(crng.Value) Then
Mnum = Evaluate("DateDif(""" & crng.Value & """,""" & Date & """,""m"")") - 12
If Err.Number = 0 Then
ans = Application.VLookup(Mnum, colorarray, 2, True)
If Not IsError(ans) Then
crng.Interior.ColorIndex = ans
End If
End If
End If
Next
On Error GoTo 0
End With
End Sub
これで試してみて下さい。
上記のコードでは、
(本日日付-セルの日付)-12 月数 色番号
-3 43
-2 6
-1 46
0 3
という表を配列に配置し、実際の日付で検索し色の設定を行いました。
本来は、上記の表は、どこか適当なシートのセル範囲に配置します。 そうすれば、
「入力日付から本日があと4ヶ月で以内1年の場合は青」 なんて条件が追加されても変更は殆ど上記の表にデータの追加だけで済みます。
ichinose@800円するラーメン店案内雑誌を買ったら、呆れられた
これはブックを開いた時点で走るマクロです。勿論auto_openを実行してもＯＫ。
ただ、Sheet1にデータがあるものと想定しとります。
色番号はお好きに変更してくらはい。
（弥太郎）
'--------------------------
Sub auto_open()
Dim rng As Range, i As Long, n As Integer
Set rng = Sheets("sheet1").Range("k1").Resize(Sheets("sheet1").Range("k:s").Cells.Find _
("*", , , , xlByRows, xlPrevious).Row, 9)
Application.ScreenUpdating = False '追加
rng.Interior.ColorIndex = xlNone
With CreateObject("VBScript.RegEXP")
.Pattern = "^(\d{4})/(\d{2})/(\d{2})$"
For i = 1 To rng.Rows.Count
For n = 1 To rng.Columns.Count Step 2
If .test(rng(i, n)) And IsDate(rng(i, n)) Then
Select Case DateValue(rng(i, n))
Case Is < DateSerial(Year(Now) - 1, Month(Now), Day(Now))
rng(i, n).Interior.ColorIndex = 3
Case Is <= DateSerial(Year(Now) - 1, Month(Now) + 1, Day(Now))
rng(i, n).Interior.ColorIndex = 8
Case Is <= DateSerial(Year(Now) - 1, Month(Now) + 2, Day(Now))
rng(i, n).Interior.ColorIndex = 6
Case Is <= DateSerial(Year(Now) - 1, Month(Now) + 3, Day(Now))
rng(i, n).Interior.ColorIndex = 43
End Select
End If
Next n
Next i
End With
Application.ScreenUpdating = True ’追加
End Sub
追加しますた。
（弥太郎）
み…皆様本当に有難うございます！！！ もう理解出来なくて恥ずかしいやら情けないやら…でちょっと半泣きになってました。 親切に感謝致します。
私も勉強して、いつか誰かに教えてあげられるようになりたいです。 特に弥太郎さん、全部書いて頂いて本当に有難う御座います。
書いて頂いたのを実務でも使用させて頂きますが、 さらに解明して(ここがどうしてこうなって…と)、 これからの私の勉強に役立てたいと思います。
(ajiponpon)
す…すみません、一度は解決したのですが、急遽範囲を変更されてしまって… 自分で何とかしたかったのですが、どうにもならずどうしていいのかご教授頂けますでしょうか？
範囲がG〜P列までになったので 弥太郎さんから教えていただいたauto_openでここの部分の ※シート名は実際使用のに変更してあります
Set rng = Sheets("sheet1").Range("k1").Resize(Sheets("sheet1").Range("k:s").Cells.Find _
~~~~ ~~~~~
("*", , , , xlByRows, xlPrevious).Row, 9)
波線の部分を、G1 と G:P に単純に変更するだけではダメなのでしょうか？ 変更してもP列だけがうんともすんとも言ってくれず無反応なのです…
(ajiponpon)
そないにコロコロ変更されたらかないまへんなぁ。＾＾ で結局どの列とどの列に日付が入ってますのん？ まえのデータはK・M・O・Q・S 列でしたのが G I K M O になっただけとちゃいますん？ G〜Pまで１０列になりますけど、9を10に変えればrngにP列まで格納されはしますが 前例からもうせばP列は対象外になるように思うんですが・・・。 （弥太郎）
弥太郎さん
もうホント、ただただ申し訳ありません… 「変更するから〜」と言われて私も「えぇっ！？」となってしまいました。
最終的な列は G・I・K・M・O・P となりました。 こちらで再度質問する前に試してみたのは
Set rng = Sheets("sheet1").Range("k1").Resize(Sheets("sheet1").Range("k:s").Cells.Find _
~~~~ ~~~~~
("*", , , , xlByRows, xlPrevious).Row, 9)
~~~
波線の部分を、G1 と G:P と 10 などに変更してみた事です。 単純に変更だけではダメだったでしょうか？？ 宜しくお願い致します。 (ajiponpon)
はい、それだけ変更したんではダメですワ。
OP列はそれまでの規則性から外れてますから、こんな塩梅に変更してみませう。
For i=..................
Next i
の間のコードを
For n = 1 To rng.Columns.Count
If n Mod 2 = 1 Or n = 10 Then
If .test(rng(i, n)) And IsDate(rng(i, n)) Then
Select Case DateValue(rng(i, n))
Case Is < DateSerial(Year(Now) - 1, Month(Now), Day(Now))
rng(i, n).Interior.ColorIndex = 3
Case Is <= DateSerial(Year(Now) - 1, Month(Now) + 1, Day(Now))
rng(i, n).Interior.ColorIndex = 8
Case Is <= DateSerial(Year(Now) - 1, Month(Now) + 2, Day(Now))
rng(i, n).Interior.ColorIndex = 6
Case Is <= DateSerial(Year(Now) - 1, Month(Now) + 3, Day(Now))
rng(i, n).Interior.ColorIndex = 43
End Select
End If
End If
Next n
（弥太郎）
弥太郎さん
出来ました！！出来ました！！ しかし変更したことによって今まで出来ていた事が出来なくなりました…。
変更前までは、一度色が付いたセルが空白になった時、 再度ブックを開いたら色が消えていたのですが、変更後は空白に色が残りっぱなしに…。 変更することによって生じる問題で、こればっかりは手動で消さなくてはならないものでしょうか？ 贅沢言うな！とおっしゃるならこのままにします。
(ajiponpon)
いや、その贅沢も全て受け入れるようになっとりますけど。＾＾
もひとつ意味がわかりまへんが・・・。
（弥太郎）
はい、はい、なんとなくかような現象かと思われます。
それはデータの終わりの方でっしゃろ？
それなら
rng.Interior.ColorIndex = xlNone
↓
Range("G:P").Interior.ColorIndex = xlNone
に差し替えてみたらどうでっしゃろ？
ただ、その範囲の中で検索列に色付けした大事なデータが存在しても色は消えますが。
それが嫌ならrange("G:G").interior.colorindex=xlnone といった塩梅に検索各列の
コードを書き込まなアキマヘンけど・・・。
（弥太郎）
弥太郎さん
もう、足を向けて寝れませんね…有難う御座います（TT
えと…
For n = 1 To rng.Columns.Count
If n Mod 2 = 1 Or n = 10 Then
If .test(rng(i, n)) And IsDate(rng(i, n)) Then
Select Case DateValue(rng(i, n))
Case Is < DateSerial(Year(Now) - 1, Month(Now), Day(Now))
rng(i, n).Interior.ColorIndex = 3
Case Is <= DateSerial(Year(Now) - 1, Month(Now) + 1, Day(Now))
rng(i, n).Interior.ColorIndex = 8
Case Is <= DateSerial(Year(Now) - 1, Month(Now) + 2, Day(Now))
rng(i, n).Interior.ColorIndex = 6
Case Is <= DateSerial(Year(Now) - 1, Month(Now) + 3, Day(Now))
rng(i, n).Interior.ColorIndex = 43
End Select
End If
End If
Next n
これに変更したことによって、 【変更前】 １、ブックを開くと自動で色がつく ２、色が付いた日付があったセルを空白にする（この時点では再度ブックを開くまで色は残りますよね？） ３、再度ブックを開くことによって空白にしたセルに残っていた２、の色は消えていた だったのですが 【変更後】 １、ブックを開くと自動で色がつく ２、色が付いた日付があったセルを空白にする ３、再度ブックを開いても残っていた２・の色が消えない と空白にしたセルに色だけが残っているという状態になっているんです…
この説明で分かりますでしょうか？ 何か手立てはありますでしょうか…？ (ajiponpon)
------------------------------------------ と書き込もうとしたら既に弥太郎さんが先に書き込まれていらっしゃいました。。。
出来ましたら
>それが嫌ならrange("G:G").interior.colorindex=xlnone といった塩梅に検索各列の
>コードを書き込まなアキマヘンけど・・・。
教えて頂けると有難いです…
(ajiponpon)
rng.Interior.ColorIndex = xlNone
↓
For n = 1 To rng.Columns.Count
If n Mod 2 = 1 Or n = 10 Then
rng.Columns(n).Interior.ColorIndex = xlNone
End If
Next n
こんな塩梅でどうでせう？
（弥太郎）
弥太郎さん
すみません…！ 私の理解不足か下記のようにしたのですが、何も変わりません… 置き換える所を間違えているのでしょうか？？
Sub auto_open()
Dim rng As Range, i As Long, n As Integer
Set rng = Sheets("シート名").Range("G1").Resize(Sheets("シート名").Range("G:P").Cells.Find _
("*", , , , xlByRows, xlPrevious).Row, 10)
Application.ScreenUpdating = False
For n = 1 To rng.Columns.Count
If n Mod 2 = 1 Or n = 10 Then
rng.Columns(n).Interior.ColorIndex = xlNone
End If
Next n
With CreateObject("VBScript.RegEXP")
.Pattern = "^(\d{4})/(\d{2})/(\d{2})$"
For i = 1 To rng.Rows.Count
For n = 1 To rng.Columns.Count
If n Mod 2 = 1 Or n = 10 Then
If .test(rng(i, n)) And IsDate(rng(i, n)) Then
Select Case DateValue(rng(i, n))
Case Is < DateSerial(Year(Now) - 1, Month(Now), Day(Now))
rng(i, n).Interior.ColorIndex = 3
Case Is <= DateSerial(Year(Now) - 1, Month(Now) + 1, Day(Now))
rng(i, n).Interior.ColorIndex = 46
Case Is <= DateSerial(Year(Now) - 1, Month(Now) + 2, Day(Now))
rng(i, n).Interior.ColorIndex = 6
Case Is <= DateSerial(Year(Now) - 1, Month(Now) + 3, Day(Now))
rng(i, n).Interior.ColorIndex = 4
End Select
End If
End If
Next n
Next i
End With
Application.ScreenUpdating = True
End Sub
(ajiponpon)
弥太郎さん
あ！今の状態でP列だけブックを開き直した時に空白にしたセルの色が消えています！！
(ajiponpon)
P列だけっちゅう事はない筈なんですけど・・・＾＾
そしたら
For n = 1 To rng.Columns.Count
If n Mod 2 = 1 Or n = 10 Then
rng.Columns(n).Interior.ColorIndex = xlNone
End If
Next n
コードの左側に縦に一列グレーのゾーンがありまっしゃろ？
For の行をクリックしますとその行が茶色に変わります。
F8を叩くと一行ずつコードが動きます。
そうしながらエクセルに戻って確認してみてくらはい。
どうでっか？nが１の（マウスを近づけるとチップテキストがnの値を教えてくれる）
時G列の色が消え、３の時はI列の色が消えるを確認でけまっしゃろ？
（弥太郎）
書き忘れていましたけど、
Alt＋F8でauto_openを実行するんですよ。ブックを閉じたらブレークポイントは無効
になります。
（弥太郎）
弥太郎さん
出来ました！！！出来ました！！
というのも私思い違いをしていたようです。 ブックを開いた時に色づけされて、その後に色の付いた最終行のデータを1行全て消したんです。 で、最終行には色だけが残っている状態で、再度ブックを開いたんです。 だからでしょうか？
と一人で納得してしまいましたが、…言っている意味分かりますか？？ データが何もない行は、色があっても認識してくれないのかな…？ 「最終行として認識するのはデータがある行」って納得したのですが。
(ajiponpon)
はい、良く分かります。 rngはG〜Pにある最下行（データの有る）を対象にしとりますから、色がついていても rngにはセットされまへん。 従ってG列からP列65536行まで色無しに設定したのが一番新しいコードなんですワ。 （弥太郎）
弥太郎さん
おはようございます、えっと… >従ってG列からP列65536行まで色無しに設定したのが一番新しいコードなんですワ。
For n = 1 To rng.Columns.Count
If n Mod 2 = 1 Or n = 10 Then
rng.Columns(n).Interior.ColorIndex = xlNone
End If
Next n
これですよね…？ これだとデータがある最下列より下行の色つきセルは色が消えてないです…よ？ ただ、データのある最下列までなら色は消えました…の意味で「出来ました！」と申し上げたのですが… データが無い行も色が消えていないとおかしいとおっしゃるなら、まだ出来ていません；； でも、この状態でも私がやりたい事を十分、いやそれ以上を教えて頂いて、これ以上は本当に申し訳ないので… 「解決しないままでいいのか！！」と言われればしたいですが、弥太郎さん頼りですし；
(ajiponpon)
そうでした、そうでした。（汗 >弥太郎さん頼りですし； えぇ、えぇ、頼りにして貰って結構でっせ。 なんたって、実に頼りになる「頼りない男」なんですから。＾＾ rng.Columns(n).Interior.ColorIndex = xlNone ↓ Columns(n + 6).Interior.ColorIndex = xlNone こう差し替えてみてくらはい。 （弥太郎）
弥太郎さん
ありがとうございます、完璧です！出来ました！！ ホント何でも出来てしまうんですね…；；
あの…次から次へとで申し訳ないんですが、甘えてあとひとつだけ相談に乗って頂けないでしょうか？ 今、また嫌な話が…；； 列が今後増える事もありえる…って事なのですが、この場合はまたあちこち書き換えないと いけなくなりますか…？？； （増え方にもよるとか色々条件はあるかと思いますが、今の段階ではそこまではっきりしてなくて… 答えていただける範囲内で結構です）
(ajiponpon)
はい、書き換えなくてはならないでせう。 先ずオブジェクト変数rngの範囲を書き換えなければなりまへん。 一番最初の様に隔列にという規則性があればコードは簡単になりますが、隣接したり 離れたセルだったりを検索するばやいやと少しだけ複雑になります。が、変更した時 に少なくて簡単な書き換え方法のマクロを書いておきます。 そのまま使っても現状に即していると思いますけど、ご参考に。 （弥太郎）
Sub 追加Ver()
Dim rng As Range, i As Long, n As Integer, ary
Set rng = Sheets("sheet1").Range("G1").Resize(Sheets("sheet1").Range("G:P").Cells.Find _
("*", , , , xlByRows, xlPrevious).Row, 10)
'↑この範囲を書き換え
Application.ScreenUpdating = False
ary = Array(1, 3, 5, 7, 9, 10)
'↑ これはrngに格納した検索列を変数aryに格納
r = Excel.Rows.Count
For n = 1 To rng.Columns.Count
If Not IsError(Application.Match(n, ary, 0)) Then '変数aryに格納した検索すべき列ならの意
Columns(n + 6).Interior.ColorIndex = xlNone
'↑+6と有るのはA列から指折り数えての列 G列ならnが１なら7になる
End If
Next n
With CreateObject("VBScript.RegEXP")
.Pattern = "^(\d{4})/(\d{2})/(\d{2})$"
For i = 1 To rng.Rows.Count
For n = 1 To rng.Columns.Count
If Not IsError(Application.Match(n, ary, 0)) Then '変数aryに格納した検索すべき列ならの意
If .test(rng(i, n)) And IsDate(rng(i, n)) Then
Select Case DateValue(rng(i, n))
Case Is < DateSerial(Year(Now) - 1, Month(Now), Day(Now))
rng(i, n).Interior.ColorIndex = 3
Case Is <= DateSerial(Year(Now) - 1, Month(Now) + 1, Day(Now))
rng(i, n).Interior.ColorIndex = 46
Case Is <= DateSerial(Year(Now) - 1, Month(Now) + 2, Day(Now))
rng(i, n).Interior.ColorIndex = 6
Case Is <= DateSerial(Year(Now) - 1, Month(Now) + 3, Day(Now))
rng(i, n).Interior.ColorIndex = 4
End Select
End If
End If
Next n
Next i
End With
Application.ScreenUpdating = True
End Sub
弥太郎さん
ありがとうございます！！ 自分で色々な変更を想定して検証してみました。
もし仮にE・G・I・K・M・O・P列に増えたとした時、下記のようにしてみました。 自分で試して完璧な気でいるのですが、正解でしょうか？
Sub 追加Ver()
Dim rng As Range, i As Long, n As Integer, ary
Set rng = Sheets("シート名").Range("E1").Resize(Sheets("シート名").Range("E:P").Cells.Find _
("*", , , , xlByRows, xlPrevious).Row, 12)
'↑この範囲を書き換え
Application.ScreenUpdating = False
ary = Array(1, 3, 5, 7, 9, 11, 12)
'↑ これはrngに格納した検索列を変数aryに格納
r = Excel.Rows.Count
For n = 1 To rng.Columns.Count
If Not IsError(Application.Match(n, ary, 0)) Then '変数aryに格納した検索すべき列ならの意
Columns(n + 4).Interior.ColorIndex = xlNone
'↑+6と有るのはA列から指折り数えての列 G列ならnが１なら7になる
End If
Next n
With CreateObject("VBScript.RegEXP")
.Pattern = "^(\d{4})/(\d{2})/(\d{2})$"
For i = 1 To rng.Rows.Count
For n = 1 To rng.Columns.Count
If Not IsError(Application.Match(n, ary, 0)) Then '変数aryに格納した検索すべき列ならの意
If .test(rng(i, n)) And IsDate(rng(i, n)) Then
Select Case DateValue(rng(i, n))
Case Is < DateSerial(Year(Now) - 1, Month(Now), Day(Now))
rng(i, n).Interior.ColorIndex = 3
Case Is <= DateSerial(Year(Now) - 1, Month(Now) + 1, Day(Now))
rng(i, n).Interior.ColorIndex = 46
Case Is <= DateSerial(Year(Now) - 1, Month(Now) + 2, Day(Now))
rng(i, n).Interior.ColorIndex = 6
Case Is <= DateSerial(Year(Now) - 1, Month(Now) + 3, Day(Now))
rng(i, n).Interior.ColorIndex = 4
End Select
End If
End If
Next n
Next i
End With
Application.ScreenUpdating = True
End Sub
(ajiponpon)
「ファイナルアンサー？」・・ものみんた 「あぃ」・・ajiponpon 「せぇかい〜！」・・ものみんた 大変良くでけました。これで範囲が追加されてもOKでんな。＾＾ （弥太郎）
あ、r=Excel.Rows.Countは消しとってくらはい。
違う目的に使うためのもんですから、このコードには不要です。
（弥太郎）
弥太郎さん
>あ、r=Excel.Rows.Countは消しとってくらはい。 了解しました！
ありがとうございます！！ 本当に有難う御座います！！！
１〜１０まで見捨てず教えてくださって…。 私もいつか誰かの力になれるよう頑張ります。 最後の検証で1歩とはいきませんが、１ミリ位は前進出来たと思います。 長々とお付き合い頂いて本当に有難う御座いました！（TT (ajiponpon)
[ 一覧(最新更新順) ]
YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki.
Modified by kazu.