みんなの「教えて(疑問・質問)」にみんなで「答える」Q&Aコミュニティ

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

解決済みの質問

公差を設定して判定するマクロの続き

質問No.9150010の続きです。
上記の質問で下記のようなご回答を頂きました。
E列の数値に対してB4セルに入力されている公差の数値に
H列とK列の数値が入っているか調べるマクロです。

下記のマクロで完璧に行えるようになりましたが
もしE列の数値に対して、公差内に入っていない数値がH列とK列にあった場合
その公差内に入っていないセルのみを赤く塗りつぶすには下記のマクロにどうのように追加すればよいでしょうか?
パターンとしてはH列もしくはK列のどちらかのみが公差内に入っていない時もあれば
両方とも公差内に入っていない場合もあります。


Sub 判定仮本物()
Dim i As Integer, j As Integer
Dim k As Double

Range(Cells(3, "L"), Cells(32, "L")).ClearContents
Range(Cells(3, "E"), Cells(32, "K")).Interior.ColorIndex = 0
k = Cells(4, 2) 'B4セルの値

For i = 3 To 32
If Abs(Cells(i, "E") - Cells(i, "H")) <= k And Abs(Cells(i, "E") - Cells(i, "K")) <= k Then

If i Mod 2 = 1 Then
Union(Cells(i, "E"), Cells(i, "H"), Cells(i, "K")).Interior.ColorIndex = 6
Cells(i, "L") = "OK"
Else
Union(Cells(i, "E"), Cells(i, "H"), Cells(i, "K")).Interior.ColorIndex = 40
Cells(i, "L") = "OK"
End If
End If
Next
If WorksheetFunction.CountIf(Range("L3:L32"), "OK") > 29 Then
MsgBox "データチェックOK(^O^)b"
End If
End Sub

投稿日時 - 2016-03-29 11:50:02

QNo.9150578

すぐに回答ほしいです

質問者が選んだベストアンサー

以下でいかがでしょう

Sub 判定仮本物()
Dim i As Integer, j As Integer
Dim k As Double

Range(Cells(3, "L"), Cells(32, "L")).ClearContents
Range(Cells(3, "E"), Cells(32, "K")).Interior.ColorIndex = 0
k = Cells(4, 2) 'B4セルの値

For i = 3 To 32
If Abs(Cells(i, "E") - Cells(i, "H")) <= k And Abs(Cells(i, "E") - Cells(i, "K")) <= k Then

If i Mod 2 = 1 Then
Union(Cells(i, "E"), Cells(i, "H"), Cells(i, "K")).Interior.ColorIndex = 6
Cells(i, "L") = "OK"
Else
Union(Cells(i, "E"), Cells(i, "H"), Cells(i, "K")).Interior.ColorIndex = 40
Cells(i, "L") = "OK"
End If
Else
If Abs(Cells(i, "E") - Cells(i, "H")) > k Then
Cells(i, "H").Interior.Color = vbRed
End If
If Abs(Cells(i, "E") - Cells(i, "K")) > k Then
Cells(i, "K").Interior.Color = vbRed
End If
End If
Next
If WorksheetFunction.CountIf(Range("L3:L32"), "OK") > 29 Then
MsgBox "データチェックOK(^O^)b"
End If
End Sub

投稿日時 - 2016-03-29 12:32:23

お礼

お礼が遅くなりすみませんでした。

ご回答ありがとうございました。
頂いたマクロで目的が達成できました。
本当にありがとうございました。

投稿日時 - 2016-03-31 09:43:17

ANo.1

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

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

回答(3)

ANo.3

訂正。「Hだけ塗る」と「Kだけ塗る」が逆でした。

Const OddColor As Integer = 40
Const EvenColor As Integer = 6
Const ErrorColor As Integer = 3

Sub 判定仮本物()
Dim i As Integer, j As Integer
Dim k As Double

Range(Cells(3, "L"), Cells(32, "L")).ClearContents
Range(Cells(3, "E"), Cells(32, "K")).Interior.ColorIndex = 0
k = Cells(4, 2)

For i = 3 To 32
Select Case (Abs(Cells(i, "E") - Cells(i, "H")) <= k) + (Abs(Cells(i, "E") - Cells(i, "K")) <= k) * 2
Case 0
Union(Cells(i, "H"), Cells(i, "K")).Interior.ColorIndex = ErrorColor
Case -1
Cells(i, "K").Interior.ColorIndex = ErrorColor
Case -2
Cells(i, "H").Interior.ColorIndex = ErrorColor
Case -3
Union(Cells(i, "E"), Cells(i, "H"), Cells(i, "K")).Interior.ColorIndex = EvenColor - (i Mod 2) * (EvenColor - OddColor)
Cells(i, "L") = "OK"
End Select
Next

If WorksheetFunction.CountIf(Range("L3:L32"), "OK") > 29 Then
MsgBox "データチェックOK(^O^)b"
End If
End Sub

投稿日時 - 2016-03-29 13:45:22

ANo.2

以下でどうでしょう?

Const OddColor As Integer = 40
Const EvenColor As Integer = 6
Const ErrorColor As Integer = 3

Sub 判定仮本物()
Dim i As Integer, j As Integer
Dim k As Double


Range(Cells(3, "L"), Cells(32, "L")).ClearContents
Range(Cells(3, "E"), Cells(32, "K")).Interior.ColorIndex = 0
k = Cells(4, 2)

For i = 3 To 32
Select Case (Abs(Cells(i, "E") - Cells(i, "H")) <= k) + (Abs(Cells(i, "E") - Cells(i, "K")) <= k) * 2
Case 0
Union(Cells(i, "H"), Cells(i, "K")).Interior.ColorIndex = ErrorColor
Case -1
Cells(i, "H").Interior.ColorIndex = ErrorColor
Case -2
Cells(i, "K").Interior.ColorIndex = ErrorColor
Case -3
Union(Cells(i, "E"), Cells(i, "H"), Cells(i, "K")).Interior.ColorIndex = EvenColor - (i Mod 2) * (EvenColor - OddColor)
Cells(i, "L") = "OK"
End Select
Next

If WorksheetFunction.CountIf(Range("L3:L32"), "OK") > 29 Then
MsgBox "データチェックOK(^O^)b"
End If
End Sub

if文を使わず、Select Case文で「HもKも赤くするパターン」「Hだけ赤くするパターン」「Kだけ赤くするパターン」「OKのパターン」の4つの「場合分け」をしています。

投稿日時 - 2016-03-29 13:38:33

お礼

お礼が遅くなり申し訳ありませんでした。

ご回答ありがとうございました。

頂いたマクロで目的の事ができました。
目的は同じでも色々な書き方があるんですね。
本当にいつも勉強になります。
ありがとうございました。

投稿日時 - 2016-03-31 09:44:50

あなたにオススメの質問