Question

我是VBA的新手并且有点挣扎我正在创建一份报告。在报告中，我有一个带有鲜花的下拉列表，让我们说Lilly，Rose Etc。所以当我选择Rose时，我想要一些特定的细胞变色。我不想使用条件格式，因为我需要保持电子表格尽可能小。到目前为止，我得到了

Private Sub workbook_sheetchange(ByVal Sh As Object, ByVal Targer As Rang
Select Case Range("B2")

Case " Rose"

Application.Goto Reference:="Header"
With Selection.Interior
    .Pattern = xlSolid
    .PatternColorIndex = xlAutomatic
    .ThemeColor = xlThemeColorAccent6
    .TintAndShade = -0.249977111117893
    .PatternTintAndShade = 0

End With

Application.Goto Reference:="Row"
With Selection.Interior
    .Pattern = xlSolid
    .PatternColorIndex = xlAutomatic
    .ThemeColor = xlThemeColorAccent6
    .TintAndShade = -0.249977111117893
    .PatternTintAndShade = 0

End With

Application.Goto Reference:="Fill"

With Selection.Interior
    .Pattern = xlSolid
    .PatternColorIndex = xlAutomatic
    .ThemeColor = xlThemeColorAccent6
    .TintAndShade = 0.599993896298105
    .PatternTintAndShade = 0

End With
End Select
End Sub

感谢您的帮助！

Answer 1

您为什么关注文件大小？我创建了一个完全按照您的要求使用条件格式设置的工作簿，文件大小为10.5Kb !!!

如果你真的想在VBA中这样做：

1 - 使用工作表更改事件检测B2是否已更改

Private Sub Worksheet_Change(ByVal Target As Range)
    If Not Application.Intersect(Range("B2"), Range(Target.Address)) Is 
            MsgBox "Cell B2 has been changed"
    End If
End Sub

2 - 根据下拉框测试数据中的每个单元格。我假设您的数据在此示例中的范围为A1到A10。

For Row = 1 To 10
    If Range("A" & Row).Value = Range("B2").Value Then
        'Colour your cell
    Else
        'Clear the colour from your cell
    End If
Next Row

希望上面给你一个开始。

Answer 2

你可能在此之后：

Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)

    If Target.Address <> "$B$2" Then Exit Sub '<--| exit if "changed" cell is not "B2"

    With Sh '<--| reference sheet with "changed" cell
        Select Case .Range("B2").Value '<--| act with respect to B2 cell current value
            Case "Rose"
                With .Range("Header").Interior '<--| reference the specific named range instead of using 'Application.GoTo' method and 'Selection' object
                    .Pattern = xlSolid
                    .PatternColorIndex = xlAutomatic
                    .ThemeColor = xlThemeColorAccent6
                    .TintAndShade = -0.249977111117893
                    .PatternTintAndShade = 0
                End With

                With .Range("Row").Interior '<--| reference the specific named range instead of using 'Application.GoTo' method and 'Selection' object
                    .Pattern = xlSolid
                    .PatternColorIndex = xlAutomatic
                    .ThemeColor = xlThemeColorAccent6
                    .TintAndShade = -0.249977111117893
                    .PatternTintAndShade = 0
                End With

                With .Range("Fill").Interior '<--| reference the specific named range instead of using 'Application.GoTo' method and 'Selection' object
                    .Pattern = xlSolid
                    .PatternColorIndex = xlAutomatic
                    .ThemeColor = xlThemeColorAccent6
                    .TintAndShade = 0.599993896298105
                    .PatternTintAndShade = 0
                End With
        End Select
    End With
End Sub

可以更有效地重构为：

Option Explicit

Private Sub workbook_sheetchange(ByVal Sh As Object, ByVal Target As Range)

    If Target.Address <> "$B$2" Then Exit Sub '<--| exit if "changed" cell is not "B2"

    With Sh '<--| reference sheet with "changed" cell
        Select Case .Range("B2") '<--| act with respect to B2 cell current value
            Case "Rose"
                FormatCell Union(.Range("Header"), .Range("Row"), .Range("Fill")), _
                           xlSolid, _
                           xlAutomatic, _
                           xlThemeColorAccent6, _
                           -0.249977111117893, _
                           0 '<--| reference all listed named ranges and format their 'Interior' object with passed properties
                .Range("Fill").Interior.TintAndShade = 0.599993896298105 '<--| change only "Fill" named range 'Interior' 'TintAndShade' property
        End Select
    End With
End Sub

Sub FormatCell(cell As Range, pttrn As XlPattern, pttrnClrIndx As XlColorIndex, thmClr As XlThemeColor, tntAndShd As Single, pttrnTntAndShd As Variant)
    With cell.Interior
        .pattern = pttrn
        .PatternColorIndex = pttrnClrIndx
        .ThemeColor = thmClr
        .TintAndShade = tntAndShd
        .PatternTintAndShade = pttrnTntAndShd
    End With
End Sub

从下拉列表中选择Vba代码值列出一些颜色的单元格

2 个答案: