根据 1 个单元格更改部分行的背景颜色

Question

所以我的 VBA 编码处于最后一个障碍。我正在为几个不同的国家/地区创建时间表，并且需要单元格 A7:H300 的背景根据作为国家/地区代码的同一特定行中的值自动着色。

我知道我可以使用条件格式，但使用该方法无法将颜色复制并粘贴到单独的 sheet 中。

我下面的代码有效，但它的颜色是 D:K 而不是预期的 A:H - 该值在 D 行，所以我猜这就是问题所在，但我无法锻炼绕过它。

谢谢你的帮助:)

Sub ChangeColour()

Set PC = Range("A:H")
For Each cell In PC
If cell.Value = "BEZEE" Then cell.Columns("A:H").Interior.ColorIndex = 40
If cell.Value = "BEANR" Then cell.Columns("A:H").Interior.ColorIndex = 40
If cell.Value = "DEBRH" Then cell.Columns("A:H").Interior.ColorIndex = 37
If cell.Value = "FRLEH" Then cell.Columns("A:H").Interior.ColorIndex = 38
If cell.Value = "GBBRS" Then cell.Columns("A:H").Interior.ColorIndex = 35
If cell.Value = "GBLPL" Then cell.Columns("A:H").Interior.ColorIndex = 35
If cell.Value = "GBSOU" Then cell.Columns("A:H").Interior.ColorIndex = 35
If cell.Value = "NLRTM" Then cell.Columns("A:H").Interior.ColorIndex = 40
If cell.Value = "FIHNO" Then cell.Columns("A:H").Interior.ColorIndex = 36
If cell.Value = "SEGOT" Then cell.Columns("A:H").Interior.ColorIndex = 36
If cell.Value = "ZADUR" Then cell.Columns("A:H").Interior.ColorIndex = 45
If cell.Value = "ZAELS" Then cell.Columns("A:H").Interior.ColorIndex = 45
If cell.Value = "ZAPLZ" Then cell.Columns("A:H").Interior.ColorIndex = 45

Next

End Sub

Answer 1

您正在寻址错误的范围。您尝试这样做的方式有效地充当了引用 Cell 的 Offset。更好的写法如下：

Public Sub ChangeColour()
    Dim PC As Range, LastRow As Range
    Dim ColorIndexValue As Long
    Dim cell

    ' Set your desired range - Should reference Relevant worksheet as well
    Set PC = Range("A7:H1000")

    ' Find last used row in that range - This will help limit the number of loops on a fixed range and speed up execution
    Set LastRow = PC.Find(what:="*", _
                          after:=Cells(PC.Row, PC.Column), _
                          lookat:=xlWhole, _
                          LookIn:=xlValues, _
                          searchorder:=xlByRows, _
                          searchdirection:=xlPrevious)

    If Not LastRow Is Nothing Then
        ' Resize PC to actual used range instead of working on entire sheet
        Set PC = PC.Cells(1).Resize(LastRow.Row, PC.Columns.Count)

        ' Loop through all cells in range in Column D
        For Each cell In PC.Columns("D").Cells
            ' Set ColorIndexValue variable based on cell value
            Select Case cell.Value2
                Case "GBBRS", "GBLPL", "GBSOU": ColorIndexValue = 35
                Case "FIHNO", "SEGOT": ColorIndexValue = 36
                Case "BEANR", "DEBRH": ColorIndexValue = 37
                Case "FRLEH": ColorIndexValue = 38
                Case "BEZEE", "NLRTM": ColorIndexValue = 40
                Case "ZADUR", "ZAELS", "ZAPLZ": ColorIndexValue = 45
                Case Else: ColorIndexValue = 0
            End Select
            ' Set cell Color. Skip 0 as assume cell is 0 by default
            If ColorIndexValue > 0 Then
                ' Calculates applicable range from cell and PC context
                With Range(cell.Offset(0, PC.Cells(1).Column - cell.Column), cell.Offset(0, PC.Cells(1, PC.Columns.Count).Column - cell.Column))
                    .Interior.ColorIndex = ColorIndexValue
                End With
            End If
        Next cell
    End If
End Sub

Answer 2

我想你可以试试：

Option Explicit

Sub test()

    Dim Lastrow As Long, i As Long

    With ThisWorkbook.Worksheets("Sheet1")

        Lastrow = .Cells(.Rows.Count, "D").End(xlUp).Row

        For i = 1 To Lastrow

            If .Range("D" & i).Value = "BEZEE" Or .Range("D" & i).Value = "BEANR" Or .Range("D" & i).Value = "NLRTM" Then
                .Range("A" & i & ":H" & i).Interior.ColorIndex = 40
            ElseIf .Range("D" & i).Value = "DEBRH" Then
                .Range("A" & i & ":H" & i).Interior.ColorIndex = 37
            ElseIf .Range("D" & i).Value = "FRLEH" Then
                .Range("A" & i & ":H" & i).Interior.ColorIndex = 38
            ElseIf .Range("D" & i).Value = "GBBRS" Or .Range("D" & i).Value = "GBLPL" Or .Range("D" & i).Value = "GBSOU" Then
                .Range("A" & i & ":H" & i).Interior.ColorIndex = 35
            ElseIf .Range("D" & i).Value = "FIHNO" Or .Range("D" & i).Value = "SEGOT" Then
                .Range("A" & i & ":H" & i).Interior.ColorIndex = 36
            ElseIf .Range("D" & i).Value = "ZADUR" Or .Range("D" & i).Value = "ZAELS" Or .Range("D" & i).Value = "ZAPLZ" Then
                .Range("A" & i & ":H" & i).Interior.ColorIndex = 45
            End If

        Next i

    End With

根据 1 个单元格更改部分行的背景颜色

change background colour for partial row dependant on 1 Cell

excel

vba

background-color