こんにちはゲストさん。会員登録(無料)して質問・回答してみよう!

締切り済みの質問

EXCELで4色の色をつけるVBA(既存)を最後のシートまで実行するには?

エクセルのVBAで質問です。

現在、下記のVBAにて、エクセルに4色の色をつけています。

内容
・処理範囲内(D5:AI50)の列の値が、
・指定した行(4行目)の値から見て、
・+5、+10、-5、-10の場合、それぞれ指定した色をつけています
・ただしC列の値が30未満の行は色付けなし

現状では、このマクロはアクティブシートのみで使えるため、
100シートあれば、それぞれのシートにおいて
そのつどマクロを実行しています。
これを、一度の実行で最終シートまで実行できるようにしたいのです。

VBA初心者のため、見よう見まねでループを試してみたものの、
どうもうまく動きませんでした。

なにとぞご教授のほど、お願いいます。

●以下、現在使用しているVBA

Sub 条件付4色の標本数1()

Dim 処理範囲 As Range
Dim 先頭の行番号 As Long
Dim 全体の行数 As Long
Dim 各セル As Range
Dim 差分 As Single
Dim 標本数 As Single

Set 処理範囲 = Range("D5:AI50")
For Each 各セル In 処理範囲
標本数 = Cells(各セル.Row, "C").Value
If 標本数 >= 30 Then
差分 = 各セル.Value - Cells(4, 各セル.Column).Value    Select Case 差分
Case Is <= -10
各セル.Interior.ColorIndex = 37 'ペールブルー
各セル.Font.ColorIndex = 1
Case Is <= -5
各セル.Interior.ColorIndex = 34 '薄い水色
各セル.Font.ColorIndex = 1
Case Is >= 10
各セル.Interior.ColorIndex = 6 '黄37
各セル.Font.ColorIndex = 1
Case Is >= 5
各セル.Interior.ColorIndex = 19 '薄い黄
各セル.Font.ColorIndex = 1
Case Else
各セル.Interior.ColorIndex = xlNone '無色
End Select
End If
Next
End Sub

投稿日時 - 2008-05-16 14:10:16

QNo.4026457

すぐに回答ほしいです

このQ&Aは役に立ちましたか?

1人が「このQ&Aが役に立った」と投票しています

回答(2)

ANo.2

For eachを使う方法のほかに、全てのシートを1つずつ捉えるには
Sub test01()
MsgBox Sheets.Count
For i = 1 To Sheets.Count
MsgBox Sheets(i).Name
Next i
End Sub
を実行してみて、こういう方法もあるということを知ってください。

投稿日時 - 2008-05-16 21:34:27

ANo.1

For Each の使い方を解っているようなので、シートもFor Eachで回せば良いだけです。

検証していないので、動かない可能性大です(笑)

Sub 条件付4色の標本数1()

Dim 処理範囲 As Range
Dim 先頭の行番号 As Long
Dim 全体の行数 As Long
Dim 各シート As Worksheet
Dim 各セル As Range
Dim 差分 As Single
Dim 標本数 As Single

For Each 各シート In Worksheets
With 各シート
Set 処理範囲 = .Range("D5:AI50")
For Each 各セル In 処理範囲
標本数 = .Cells(各セル.Row, "C").Value
If 標本数 >= 30 Then
差分 = 各セル.Value - .Cells(4, 各セル.Column).Value
Select Case 差分
Case Is <= -10
各セル.Interior.ColorIndex = 37 'ペールブルー
各セル.Font.ColorIndex = 1
Case Is <= -5
各セル.Interior.ColorIndex = 34 '薄い水色
各セル.Font.ColorIndex = 1
Case Is >= 10
各セル.Interior.ColorIndex = 6 '黄37
各セル.Font.ColorIndex = 1
Case Is >= 5
各セル.Interior.ColorIndex = 19 '薄い黄
各セル.Font.ColorIndex = 1
Case Else
各セル.Interior.ColorIndex = xlNone '無色
End Select
End If
Next 各セル
End With
Next 各シート
End Sub

投稿日時 - 2008-05-16 14:21:41

お礼

ありがとうございます。
非常にスムーズに動きました!
このVBA自体、自分で作ったわけでなないのですが、
勉強したいと思いました。

投稿日時 - 2008-05-16 18:08:08

あなたにオススメの質問