vba條件格式化到列

Question

我是VBA的新手，所以我遇到了幾個問題。

我有一個數據集，看起來像這樣：

我不得不塔A比較列B，C，d，E和F，然後着色細胞的字體列乙：F在這些條件下：

1. 如果列A中的單元格與列B：F中的單元格相同，則將它們的字體繪製爲橙色。
2. 如果列A中的單元格高於列B：F中的單元格，則將它們的字體塗成紅色。
3. 如果列A中的單元格低於列B：F中的單元格，則將它們的字體繪製爲綠色。
4. 如果A列與其餘列（B：F）之間的絕對差值小於1，則將它們的字體塗成橙色。

我試圖寫一個簡單的宏，所有條件都滿足，除了第四。

這是我的嘗試。

---

Sub ConditionalFormating() 
Dim i, j, a As Double 
    a = 0.99 
    i = 2 
    j = 2 

    For j = 1 To 6  
    For i = 2 To 10 

    ActiveSheet.Cells(i, j).Select 


    If ActiveSheet.Cells(i, j) - ActiveSheet.Cells(i, 1) >= a Then 

    With Selection.Interior 
     .Pattern = xlSolid 
     .PatternColorIndex = xlAutomatic 
     .Color = RGB(255, 156, 0) 
     .TintAndShade = 0 
     .PatternTintAndShade = 0 
    End With 
    End If 


    If ActiveSheet.Cells(i, j) - ActiveSheet.Cells(i, 1) <= a Then 

    With Selection.Interior 
     .Pattern = xlSolid 
     .PatternColorIndex = xlAutomatic 
     .Color = RGB(255, 156, 0) 
     .TintAndShade = 0 
     .PatternTintAndShade = 0 
    End With 
    End If 


    If ActiveSheet.Cells(i, j) > ActiveSheet.Cells(i, 1) Then 

    With Selection.Interior 
     .Pattern = xlSolid 
     .PatternColorIndex = xlAutomatic 
     .Color = RGB(0, 255, 0) 
     .TintAndShade = 0 
     .PatternTintAndShade = 0 
    End With 
    End If 



    If ActiveSheet.Cells(i, j) < ActiveSheet.Cells(i, 1) Then 

    With Selection.Interior 
     .Pattern = xlSolid 
     .PatternColorIndex = xlAutomatic 
     .Color = RGB(255, 0, 0) 
     .TintAndShade = 0 
     .PatternTintAndShade = 0 
    End With 
    End If 

    Next 
    Next 
End Sub 

---

誰能幫助我？我不明白爲什麼第四種情況在所有其他情況下都沒有得到滿足。

預先感謝您！

Answer 1

要爲字體着色，必須使用Range的Font屬性，如：Selection.Font.Color = RGB（255,128,0）。

Answer 2

你可以試試這個（註釋）代碼：

Option Explicit 

Sub ConditionalFormating() 
    Dim cell As Range, cell2 As Range, dataRng As Range 
    Dim colOrange As Long, colRed As Long, colGreen As Long, col As Long 

    colOrange = RGB(255, 156, 0) 
    colRed = RGB(255, 0, 0) 
    colGreen = RGB(0, 255, 0) 

    With Worksheets("CF") '<--| reference the relevant worksheet (change "CF" to your actual worksheet name) 
     Set dataRng = Intersect(.Columns("B:F"), .UsedRange) 
     For Each cell In .Range("A2", .Cells(.Rows.Count, 1).End(xlUp)).SpecialCells(xlCellTypeConstants) '<-- loop through its column "A" not empty cells from row 1 down to last not empty one 
      If WorksheetFunction.CountA(Intersect(dataRng, cell.EntireRow)) > 0 Then ' if current row has data 
       For Each cell2 In Intersect(dataRng, cell.EntireRow).SpecialCells(xlCellTypeConstants) ' loop through current column "A" cell row not empty cells 
        Select Case True '<-- check the current datum against the following conditions 
         Case cell2.Value = cell.Value Or Abs(cell.Value - cell2.Value) < 1 'if current datum equals corresponding value in column "A" or their absolute difference is lower than 1 
          col = colOrange 
         Case cell2.Value < cell.Value 'if current datum is lower then corresponding value in column "A" 
          col = colRed 
         Case cell2.Value > cell.Value 'if current datum is higher then corresponding value in column "A" 
          col = colGreen 
        End Select 
        With cell2.Interior 
         .Pattern = xlSolid 
         .PatternColorIndex = xlAutomatic 
         .Color = col 
         .TintAndShade = 0 
         .PatternTintAndShade = 0 
        End With 
       Next cell2 
      End If 
     Next cell 
    End With 
End Sub