Надеюсь, это то, что вы ищете.Я поместил свои индексы цветов в первый столбец и цвета во второй столбец, но вы можете изменить его в соответствии с вашими потребностями.Я основал свой код на некоторых предположениях, так как вопрос нуждается в дополнительном пояснении.Если вам нужна дополнительная помощь, пожалуйста, дайте мне знать.Ниже моя попытка:
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
и, наконец, несколько снимков экрана:
