[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
『条件にあったセルの右隣のセルに色をつけるマクロ』（WATA）
[『条件にあったセルの右となりのセルに色をつけるマクロを教えていただきたいのです
』（WATA）Ｅｘｃｅｌ２００３ ｗｉｎｄｏｗｓＸＰ ]
条件７つに 7色に塗りわけたいのですが
Ａ Ｂ Ｃ D E F
1020060901 10000 3020060901 5000 5020060930 5000
8020060930 50000 7020060930 200
2020060901 25000 6020060930 5000
A列 c列 E列 G列 に 10200609で始まっていたならば 黄色 20200609で始まっていたならば茶色 30200609で始まっていたならば 緑 50200609で始まっていたなら オレンジ
60200609ならば 赤 70200609で始まっていたならば 青のいろを その隣りのセルにいろを
つけたいのですがそれぞれの列にデーターはずっと下まで続いています。宜しくお願い致します。
こんな感じでいかがでしょう？
範囲を選択して「WATA」を実行してください＾＾
Sub WATA()
Dim Col As Integer
Dim Rng As Range
For Each Rng In Selection
If Rng.Value Like "?0200609*" Then
Select Case Left(Rng, 1)
Case 1: Col = 6
Case 2: Col = 53
Case 3: Col = 10
Case 4: Col = 0
Case 5: Col = 46
Case 6: Col = 3
Case 7: Col = 5
Case Else: Col = xlNone
End Select
With Rng.Offset(0, 1).Interior
.ColorIndex = Col
End With
End If
Next Rng
End Sub
※７つと言う割には、「40200609」が抜けてましたので、色番号「0」にしてあります。
お好きな色番号を入れてください。
（キリキ）（〃⌒o⌒)b
こんな感じでいかがでしょう？
Sub WATA()
Dim Col As Integer
Dim Rng As Range
Dim MyC As Variant
For Each MyC In Array("A", "C", "E", "G")
For Each Rng In Range(MyC & 1, Range(MyC & Rows.Count).End(xlUp))
If Rng.Value Like "?0200609*" Then
Select Case Left(Rng, 1)
Case 1: Col = 6
Case 2: Col = 53
Case 3: Col = 10
Case 4: Col = 0
Case 5: Col = 46
Case 6: Col = 3
Case 7: Col = 5
Case Else: Col = xlNone
End Select
With Rng.Offset(0, 1).Interior
.ColorIndex = Col
End With
End If
Next Rng
Next MyC
End Sub
（キリキ）（〃⌒o⌒)b
A
2006090110 5000 2006093020 10000
2006073130 5000 2006093031 5000
2006093040 20000
2006093070 25000
2006093030 50000
2006090110 5000 2006093080 5000
Sub syubetu3()
Dim Col As Integer
Dim Rng As Range
Dim MyC As Variant
tuki = InputBox("月初期値を入力してください。")
For Each MyC In Array("A", "C", "E", "G")
For Each Rng In Range(MyC & 1, Range(MyC & Rows.Count).End(xlUp))
If Rng >= tuki Then
If Rng.Value Like "*??" Then
Select Case Right(Rng, 2)
Case 10: Col = 6
Case 20: Col = 53
Case 30: Col = 7
Case 31: Col = 10
Case 40: Col = 8
Case 60: Col = 46
Case 70: Col = 3
Case 80: Col = 5
Case Else: Col = xlNone
End Select
With Rng.Offset(0, 1).Interior
.ColorIndex = Col
End With
End If
Next Rng
End If
Next MyC
End Sub
tukiにはどのようなものが入りますか？ 最後のEnd Ifはループの中にいれないとだめだと思います。 (ROUGE)
Like演算子の条件も気になります・・・ （キリキ）（〃⌒o⌒)b
こちらでいかがでしょうか？
Sub WATA2()
Dim Col As Integer
Dim Rng As Range
Dim MyC As Variant, tuki As Variant
tuki = InputBox("月初期値を入力してください。")
If tuki = Empty Then MsgBox "キャンセルしました。": Exit Sub
For Each MyC In Array("A", "C", "E", "G")
For Each Rng In Range(MyC & 1, Range(MyC & Rows.Count).End(xlUp))
If Rng.Value Like tuki & "*" Then
Select Case Right(Rng, 2)
Case 10: Col = 6
Case 20: Col = 53
Case 30: Col = 7
Case 31: Col = 10
Case 40: Col = 8
Case 60: Col = 46
Case 70: Col = 3
Case 80: Col = 5
Case Else: Col = xlNone
End Select
Else
Col = xlNone
End If
With Rng.Offset(0, 1).Interior
.ColorIndex = Col
End With
Next Rng
Next MyC
End Sub
（キリキ）（〃⌒o⌒)b
tukiには20060910とか入れるつもりで、End Ifをどこに入れてよいのか分からなかったのです。キリキ先生ありがとうございます。今マクロ実行いたしました素晴らしいです
200609と入力したなら出したかった結果がでました。教えていただいた内容を確認しながら今やっと理解できたところです。本当に何度もありがとうございます。（WATA)
また、どうしてよいのかどうかご指導お願いできないでしょうか？
F列 G列 Ｈ列 I列 に数式をいれた後コピー値のみ貼り付けにしてから教えていただいた
マクロで色つけましたがG列 I列に色がつきません。又（Ｆ,2)(Ｇ,2)(Ｈ,2)(Ｉ,2)の数式
マクロの記録で最終行までコピーしましたが、本当はＢＥ列のデータの最終行の行と同じ行
までコピーしたいのです。下のマクロはRange("F2").Selectの行までマクロの記録ですが
ＲＣ１＜＝Ｒ１Ｃ１は＄Ａ２＜＝＄Ａ＄１と入力したのですがどうしてこのような表示になるのでしょうかマクロはG列I列に色がつかなかったほかは、思ったようにできたのですが・・・
宜しくお願い致します（ＷＡＴＡ）
Range("F2").Select
ActiveCell.FormulaR1C1 = _
"=IF(RC1<=R1C1,IF(RC50=""08A"",RC1+19880000&""80"",0))"
ActiveCell.FormulaR1C1 = _
"=IF(RC1<=R1C1,IF(RC50=""08A"",RC1+19880000&""80"",0),0)"
Selection.Copy
Range("F3").Select
Range(Selection, Selection.End(xlDown)).Select
ActiveSheet.Paste
Application.CutCopyMode = False
Range("G2").Select
ActiveCell.FormulaR1C1 = "=IF(RC1<=R1C1,IF(RC50=""08A"",RC5,0))"
ActiveCell.FormulaR1C1 = "=IF(RC1<=R1C1,IF(RC50=""08A"",RC5,0),0)"
Selection.Copy
Range("G3").Select
Range(Selection, Selection.End(xlDown)).Select
ActiveSheet.Paste
Application.CutCopyMode = False
Range("H2").Select
ActiveCell.FormulaR1C1 = _
"=IF(RC1<=R1C1,IF(RC50=""08A"",RC1+19880000&""31"",0))"
ActiveCell.FormulaR1C1 = _
"=IF(RC1<=R1C1,IF(RC50=""08A"",RC1+19880000&""31"",0),0)"
Selection.Copy
Range("H3").Select
Range(Selection, Selection.End(xlDown)).Select
ActiveSheet.Paste
Application.CutCopyMode = False
Range("I2").Select
ActiveCell.FormulaR1C1 = "=IF(RC1<=R1C1,IF(RC50=""08A"",RC2,0))"
ActiveCell.FormulaR1C1 = "=IF(RC1<=R1C1,IF(RC50=""08A"",RC2,0),0)"
Selection.Copy
Range("I3").Select
Range(Selection, Selection.End(xlDown)).Select
ActiveSheet.Paste
Application.CutCopyMode = False
Columns("F:I").Select
Selection.Copy
Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=False
ActiveSheet.Paste
Application.CutCopyMode = False
Range("F2").Select
Dim Col As Integer
Dim Rng As Range
Dim MyC As Variant, tuki As Variant
tuki = InputBox("月初期値を入力してください。")
If tuki = Empty Then MsgBox "キャンセルしました。": Exit Sub
For Each MyC In Array("F", "H", "J", "L", "N", "P", "R", "T", "V")
For Each Rng In Range(MyC & 1, Range(MyC & Rows.Count).End(xlUp))
If Rng.Value Like tuki & "*" Then
Select Case Right(Rng, 2)
Case 10: Col = 6
Case 20: Col = 53
Case 31: Col = 7
Case 32: Col = 10
Case 40: Col = 8
Case 60: Col = 46
Case 70: Col = 3
Case 80: Col = 5
Case Else: Col = xlNone
End Select
Else
Col = 2
End If
With Rng.Offset(0, 1).Interior
.ColorIndex = Col
End With
Next Rng
Next MyC
End Sub
う～ん。。。 コレだけでは情報不足かな～ F2 に入っている関数は、 =IF($A2<=$A$1,IF($AX2="08A",$A2+19880000&"80",0)) が、先に入っていて、その上から =IF($A2<=$A$1,IF($AX2="08A",$A2+19880000&"80",0),0) と、上書きされています。。。 同じく、G2 には、 =IF($A2<=$A$1,IF($AX2="08A",$E2,0)) の上に =IF($A2<=$A$1,IF($AX2="08A",$E2,0),0) が、、、 H2 には、 =IF($A2<=$A$1,IF($AX2="08A",$A2+19880000&"31",0)) を =IF($A2<=$A$1,IF($AX2="08A",$A2+19880000&"31",0),0) I2 には、 =IF($A2<=$A$1,IF($AX2="08A",$B2,0)) を =IF($A2<=$A$1,IF($AX2="08A",$B2,0),0) へ。
上記の説明と、各々のセルには一体何が入っているのでしょう？ 表構成がわかりません。。。 （キリキ）（〃⌒o⌒)b
よくわかってないかもですが、、、
こんな感じでしょうか？
Sub WATA3()
Dim R As Long
Dim Col As Integer
Dim Rng As Range
Dim MyC As Variant, tuki As Variant
For R = 2 To Range("AX" & Rows.Count).End(xlUp).Row
If Range("AX" & R).Value = "08A" And Range("A" & R).Value <= Range("A1").Value Then
Range("F" & R) = Range("A" & R).Value + 19880000 & "80"
Range("H" & R) = Range("A" & R).Value + 19880000 & "31"
Range("G" & R) = Range("E" & R).Value
Range("I" & R) = Range("B" & R).Value
End If
Next R
tuki = InputBox("月初期値を入力してください。")
If tuki = Empty Then MsgBox "キャンセルしました。": Exit Sub
For Each MyC In Array("F", "H", "J", "L", "N", "P", "R", "T", "V")
For Each Rng In Range(MyC & 1, Range(MyC & Rows.Count).End(xlUp))
If Rng.Value Like tuki & "*" Then
Select Case Right(Rng, 2)
Case 10: Col = 6
Case 20: Col = 53
Case 30: Col = 7
Case 31: Col = 10
Case 40: Col = 8
Case 60: Col = 46
Case 70: Col = 3
Case 80: Col = 5
Case Else: Col = xlNone
End Select
Else
Col = 2
End If
With Rng.Offset(0, 1).Interior
.ColorIndex = Col
End With
Next Rng
Next MyC
End Sub
※先生はやめてくらはい＾＾；
（キリキ）（〃⌒o⌒)b
早速ありがとうございます。まずはお礼申し上げます。やってみます。（ＷＡＴＡ）
> If tuki = Empty Then MsgBox "キャンセルしました。": Exit Sub
は
With CreateObject("VBScript.RegExp")
.Pattern = "^\d{8}$"
If Not .test(tuki) Then: MsgBox "不正な入力です": Exit Sub
End With
の方がよいのでは？
(ROUGE)
>の方がよいのでは？
そりゃ～、ROUGE先輩のように、正規表現をマスターして
使えればかっこいいですけど。。。
σ(^o^;)も勉強してみようかしら？
んで、
日付を検索するにあたって、年・月までは最低入力。
年・月・日・コードまでを最大入力とすると、、、
.Pattern = "^\d{6,10}$"
こんな感じ？
こっちでもいいのか？
.Pattern = "^2\d{5,9}$"
（キリキ）（〃⌒o⌒)b
報告遅くなり申し訳ございません。やりたかったように出来ました。いろいろとありがとうございました。
ただまだ自分でわかっていないところもあるので勉強中です。（ＷＡＴＡ）
[ 一覧(最新更新順) ]
YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki.
Modified by kazu.