Vba代码从下拉列表中select值List以颜色填充某些单元格

我是VBA新手，有点挣扎。
我正在创build一个报告。 在报告中，我有一个花下拉列表，让我们说莉莉，玫瑰等。所以，当我select玫瑰我想要一些特定的单元格获取颜色。 我不想使用条件格式，因为我需要保持电子表格尽可能小。 到目前为止我得到了

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

你可能会在这之后：

 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 

Answer 2

为什么你关心文件大小？ 我已经创build了一个工作簿，完全按照您的要求使用条件格式，文件大小为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 – 在您的下拉框中testing数据中的每个单元格。 在这个例子中，我假设你的数据在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 

希望以上给你一个开始。