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

和最后，一些屏幕截图：

范围背景颜色更改按钮

1 个答案: