Блог

я новичок в VBA, поэтому сталкиваюсь с несколькими проблемами.

У меня есть набор данных, который выглядит следующим образом:

Я должен сравнить столбец A со столбцами B, C, D, E и F, а затем раскрасить шрифты ячеек в столбцах B: F при следующих условиях:

1. Если ячейки в столбце A совпадают с ячейками в столбцах B: F, покрасьте их шрифт оранжевым.
2. Если ячейки в столбце A выше, чем ячейки в столбцах B: F, покрасьте их шрифт в красный цвет.
3. Если ячейки в столбце A ниже, чем ячейки в столбцах B: F, закрасьте их шрифт зеленым.
4. Если абсолютная разница между столбцом A и остальными столбцами (B: F) меньше 1, покрасьте их шрифт оранжевым.

Я попытался написать простой макрос, и все условия выполнены, кроме 4-го.

Вот моя попытка.

 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
  

Кто-нибудь может мне помочь? Я не могу понять, почему 4-е условие не выполняется, когда выполняются все остальные.

Заранее благодарю вас!

Чтобы раскрасить шрифт, вы должны использовать свойство шрифта Range, например: Selection.Font .Цвет = RGB (255,128,0).

вы могли бы попробовать этот (прокомментированный) код:

 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