Excel_VBA 2列を比較し、同番号行色付け

質問

• Excel_VBAを使用して、2つの列を比較し、同じ番号の行に色を付けたいと考えています。
• 色付けする際には、特定の条件を満たす行に特定の色を付けたいです。
• また、最新の日付の行にある特定のコードと同じコードの行にも色を付けたいです。

回答No.4

kagakusuki

>A列の3の行（Excelでいう4行目）でいうと、D列「-29600」とH列「29600」は異なるのに、青い色がつくようです。ただ青や赤の色付けの判断はここではないようです。

　申し訳御座いません。
　意図したものではなかったのですが、

>F列の日付は、9/25が2行あるため、ここで判断しているようです

というVBAになってしまっておりました。
　取り急ぎ、D列とH列の値が異なっていても赤や青や緑の色が付くという点だけは解消したVBAを御伝えしておきます。
　但し、これに関しましても、日付が最終日でD列とH列の値が同じになっている行が複数ある場合には、色変わりの行が複数生じてしまいます。

Sub QNo924060_Excel_VBA_2列を比較し同番号行色付け()

Const CodeName = "コード" '「コード」を入力する列の項目名
Const DateName = "日付け" '「日付け」を入力する列の項目名
Const FlagName = "ステータス" '「フラグ」を入力する列の項目名
Const MoneyName1 = "販売額A" '「金額その1」を入力する列の項目名
Const MoneyName2 = "販売額B" '「金額その2」を入力する列の項目名
Const MatchName = "マッチ" '「金額その1」と「金額その2」が異なっている場合に「NO」を入力する列の項目名
Const Flag0 = "NO" '「金額その1」と「金額その2」が異なっている場合に「マッチ」の列に入力されている値
Const Flag1 = "good" '「フラグ」(ステータス)を入力する列に入力されているフラグ用の文字列その1(半角小文字)
Const Flag2 = "bad" '「フラグ」(ステータス)を入力する列に入力されているフラグ用の文字列その2(半角小文字)
Dim ItemRow As Long, LastRow As Long, FirstColumn As Long, LastColumn As Long _
, CodeColumn As Long, DateColumn As Long, FlagColumn As Long _
, MoneyColumn1 As Long, MoneyColumn2 As Long, MatchColumn As Long _
, myColor As Long, i As Long, tempArray As Variant, buf As Variant

For i = 1 To 9
If WorksheetFunction.CountIf(Columns(i), "*?") > 0 Then
buf = WorksheetFunction.Match("*?", Columns(i), 0)
If buf > ItemRow Then ItemRow = buf
End If
Next i
If ItemRow = 0 Then
MsgBox "項目名が入力されている行を見つける事が出来ませんでした。" _
& vbCrLf & "マクロを終了します。", vbExclamation, "項目欄不明"
Exit Sub
End If

tempArray = Array(CodeName, DateName, FlagName, MoneyName1, MoneyName2, MatchName)
For i = 0 To 5
If WorksheetFunction.CountIf(Rows(ItemRow), tempArray(i)) = 0 Then
MsgBox "「" & tempArray(i) & "」という項目名が入力されている列が見つかりません。" _
& vbCrLf & "マクロを終了します。", vbExclamation, "項目列不明"
Exit Sub
Else
buf = WorksheetFunction.Match(tempArray(i), Rows(ItemRow), 0)
Select Case i
Case 0
CodeColumn = buf
Case 1
DateColumn = buf
Case 2
FlagColumn = buf
Case 3
MoneyColumn1 = buf
Case 4
MoneyColumn2 = buf
Case 5
MatchColumn = buf
End Select
End If
Next i

FirstColumn = WorksheetFunction.Match("*?", Rows(ItemRow), 0)
LastColumn = Cells(ItemRow, Columns.Count).End(xlToLeft).column

LastRow = Cells(Rows.Count, CodeColumn).End(xlUp).row
If LastRow <= ItemRow Then
MsgBox "処理すべきデータが見当たりませんません。" & vbCrLf _
& "マクロを終了します。", vbExclamation, "データ無し"
Exit Sub
End If

Application.ScreenUpdating = False

For i = ItemRow + 1 To LastRow
If Cells(i, CodeColumn).Value <> "" _
And TypeName(Cells(i, DateColumn).Value) = "Date" _
And TypeName(Cells(i, MoneyColumn1).Value) = "Double" _
And TypeName(Cells(i, MoneyColumn2).Value) = "Double" Then
If Cells(i, MoneyColumn1).Value = Cells(i, MoneyColumn2).Value Then
If Cells(i, MatchColumn).Value = Flag0 Then Cells(i, MatchColumn).ClearContents
ElseIf Cells(i, MatchColumn).Value <> Flag0 Then Cells(i, MatchColumn).Value = Flag0
End If
End If
Next i

For i = ItemRow + 1 To LastRow
myColor = RGB(255, 255, 128)
If Cells(i, CodeColumn).Value <> "" Then
If WorksheetFunction.CountIfs(Columns(MatchColumn), "<>" & Flag0 _
, Columns(CodeColumn), Cells(i, CodeColumn).Value _
, Columns(MoneyColumn1), "<" & 9E+307 _
, Columns(MoneyColumn2), "<" & 9E+307 _
, Columns(DateColumn), "<9999/12/31") > 0 Then
If Cells(i, MatchColumn).Value <> Flag0 _
And TypeName(Cells(i, DateColumn).Value) = "Date" _
And TypeName(Cells(i, MoneyColumn1).Value) = "Double" _
And TypeName(Cells(i, MoneyColumn2).Value) = "Double" _
And WorksheetFunction.CountIfs(Columns(MatchColumn), "<>" & Flag0 _
, Columns(CodeColumn), Cells(i, CodeColumn).Value _
, Columns(DateColumn), ">" & Cells(i, DateColumn).Value) = 0 Then
Select Case StrConv(Cells(i, FlagColumn).Value, vbLowerCase + vbNarrow)
Case Flag1
myColor = RGB(128, 128, 255)
Case Flag2
myColor = RGB(255, 128, 128)
Case Else
myColor = RGB(128, 255, 128)
End Select
End If
With Range(Cells(i, FirstColumn), Cells(i, LastColumn)).Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.Color = myColor
.TintAndShade = 0
.PatternTintAndShade = 0
End With
End If
End If
Next i

Application.ScreenUpdating = True

End Sub

お礼

ありがとうございます。助かります。