按钮上的范围背景颜色更改

Question

我有一个 excel 工作簿，我在其中尝试使用宏，该宏将使用按钮运行以从“键选项卡”中获取颜色并更改格式以匹配键的格式。我有一个函数用于获取 colorIndex 并将其放在 Key 的第三列中。

我想要格式化的是跨多列的一系列单元格。

想要更改的范围： "E5:E25,G5:G25,K5:K25,L5:L25,M5:M25,T5:T25,U5:U25,V5:V25,W5:W25"

我已经查看并尝试了几种不同的方法，但似乎都没有奏效。我想看看有人如何根据密钥对颜色变化进行编码。条件格式不是一个选项，因为工作表可能会更改，因此每次都必须更改条件。

Answer 1

我希望这是您正在寻找的。我将颜色索引放在第一列，将颜色放在第二列，但您可以更改它以完全满足您的需求。我的代码基于一些假设，因为问题需要/需要一些额外的解释。如果您需要更多帮助，请告诉我。以下是我的尝试：

    Option Explicit

    'This is simply an easy call that you could substitute for a button click.
    Sub RunIT()
        CalcColorKeys "ThisSheet", True
    End Sub

    'This can be called on a button press event
    Sub CalcColorKeys(strMainSheetName As String, blnSingleLineColor As Boolean)
        Randomize  'This is required for the Rnd() function

        Dim intI As Integer
        Dim intJ As Integer
        Dim intK As Integer
        Dim rngUnion As Range
        Dim strSht As String
        Dim rngColor As Range
        Dim intR As Integer
        Dim objRefCell As Object

        Dim rngKeys As Range
        Dim vntRanges() As Variant

        strSht = strMainSheetName

        'These are the ranges that you want to change
        vntRanges = Array("E5:E25", "G5:G25", "K5:K25", "L5:L25", "M5:M25", _
                          "T5:T25", "U5:U25", "V5:V25", "W5:W25")

        'This is your reference "keys" range
        Set rngKeys = Worksheets("Keys").Range("A2:B12")

        'This is just a random number between 0 and 10 to get the row that
        '  the color lies on (You can change this to fit your needs).
        intR = Rnd() * 10
        For intI = 1 To rngKeys.Rows.Count
            If intR = CInt(rngKeys(intI, 1).Value) Then
                Set rngColor = rngKeys(intI, 2)

                Exit For
            End If
        Next intI

        'Now, join all of the data
        For intI = 0 To UBound(vntRanges)
            If intI = 0 Then
                Set rngUnion = Worksheets(strSht).Range(vntRanges(intI))
            Else
                Set rngUnion = Union(rngUnion, Worksheets(strSht).Range(vntRanges(intI)))
            End If
        Next intI

        Set objRefCell = rngColor.Cells(1, 1).Interior
        'I put this in to give you two different options for coloring!
        If blnSingleLineColor Then
            'And finally, go through it all and color it!
            With rngUnion.Interior
                .Pattern = objRefCell.Pattern
                .PatternColorIndex = objRefCell.PatternColorIndex

                'The ThemeColors run from 1 to 12 and therefore cannot be zero!
                '   see: https://docs.microsoft.com/en-us/office/vba/api/excel.xlthemecolor
                If objRefCell.ThemeColor > 0 Then
                    .ThemeColor = CLng(objRefCell.ThemeColor)
                End If
                .TintAndShade = objRefCell.TintAndShade
                .PatternTintAndShade = objRefCell.PatternTintAndShade
            End With
        Else
            'OR, You can go through each cell and colorize them that way.
            For intI = 1 To rngUnion.Areas.Count
                For intJ = 1 To rngUnion.Areas(intI).Rows.Count
                    For intK = 1 To rngUnion.Areas(intI).Columns.Count
                        With rngUnion.Areas(intI).Cells(intJ, intK).Interior
                            .Pattern = objRefCell.Pattern
                            .PatternColorIndex = objRefCell.PatternColorIndex

                            'The ThemeColors run from 1 to 12 and therefore cannot be zero!
                            '   see: https://docs.microsoft.com/en-us/office/vba/api/excel.xlthemecolor
                            If objRefCell.ThemeColor > 0 Then
                                .ThemeColor = CLng(objRefCell.ThemeColor)
                            End If
                            .TintAndShade = objRefCell.TintAndShade
                            .PatternTintAndShade = objRefCell.PatternTintAndShade
                        End With
                    Next intK
                Next intJ
            Next intI
        End If

        Set objRefCell = Nothing
        Set rngUnion = Nothing
        Set rngKeys = Nothing
        Set rngColor = Nothing

    End Sub

最后，一些屏幕截图：