vba Excel：检查值并从单元格复制颜色
声明：本页面是StackOverFlow热门问题的中英对照翻译，遵循CC BY-SA 4.0协议，如果您需要使用它，必须同样遵循CC BY-SA许可，注明原文地址和作者信息，同时你必须将它归于原作者（不是我）：StackOverFlow
原文地址: http://stackoverflow.com/questions/12515900/
Warning: these are provided under cc-by-sa 4.0 license. You are free to use/share it, But you must attribute it to the original authors (not me):
StackOverFlow
Excel: Check value and copy color from a cell
提问by Stephopolis
I feel like this question has been asked before, but I am just not really understanding the solutions. I would like to know how to check the values of some cells and copy the colors of those that match to another cell. I have a worksheet that looks like this:
我觉得这个问题以前有人问过，但我只是不太了解解决方案。我想知道如何检查某些单元格的值并复制与另一个单元格匹配的颜色。我有一个看起来像这样的工作表：
A B C D E F
1 Type Location Cell PairType PairLocation PairCell
2 EX3 1 A1 EX2 1 F3
3 EX4 1 B2 EX3 1 G3
4 EX2 1 F3 EX3 1 A1
Some of the values in A, B and C have different colors to mark them as special (background colors, not font colors). I need to take the values from column D, find the match in A and then if/when I find a match, copy the background colors from A, B and C to the background of D, E and F. If I find a D to A match (like row 2, column D to row 4, column A) then the E/F values will also match the B/C values (as shown above), so I don't have to worry about overwriting any values. I am not really fluent in Excel-ese so when I read a solution like this:
A、B 和 C 中的某些值具有不同的颜色以将它们标记为特殊（背景颜色，而不是字体颜色）。我需要从 D 列中获取值，在 A 中找到匹配项，然后如果/当我找到匹配项时，将 A、B 和 C 中的背景颜色复制到 D、E 和 F 的背景中。如果我找到了 D到 A 匹配（如第 2 行 D 列到第 4 行 A 列）然后 E/F 值也将匹配 B/C 值（如上所示），所以我不必担心覆盖任何值。我对 Excel-ese 不是很流利，所以当我阅读这样的解决方案时：
Function BGCol(MRow As Integer, MCol As Integer) As Integer
BGCol = Cells(MRow, MCol).Interior.ColorIndex
End Function
I am not really sure what I am getting myself into. Can anyone offer a solution and an explaination?
我不太确定自己在做什么。任何人都可以提供解决方案和解释吗？
回答by Vinny Roe
Sub ReColour()
Dim rStart As Range, lRow1 As Long, lRow2 As Long, lRows As Long, sFind As String
Set rStart = Sheet1.Range("A1")
lRows = rStart.Offset(65000, 0).End(xlUp).Row - rStart.Row
For lRow1 = 1 To lRows
sFind = rStart.Offset(lRow1, 3).Value
For lRow2 = 1 To lRows
If rStart.Offset(lRow2, 0).Value = sFind Then
rStart.Offset(lRow1, 3).Interior.ColorIndex = rStart.Offset(lRow2, 0).Interior.ColorIndex
rStart.Offset(lRow1, 4).Interior.ColorIndex = rStart.Offset(lRow2, 1).Interior.ColorIndex
rStart.Offset(lRow1, 5).Interior.ColorIndex = rStart.Offset(lRow2, 2).Interior.ColorIndex
Exit For
End If
Next
Next
End Sub
Sorry no time to explain right now, but I think this'll do it. You should really use something better than magic column numbers 3,4,5 etc but this is a quickndirty solution.
抱歉现在没有时间解释，但我认为这会做到。你真的应该使用比魔术列号 3、4、5 等更好的东西，但这是一个快速的解决方案。
回答by Scott Holtzman
This should work. It could be made more efficient, but it will definitely get you started.
这应该有效。它可以提高效率，但它肯定会让你开始。
Place this in a standard module and run the code (F5 or F8 to step through it). Let me know if you need more guidance.
将其放在标准模块中并运行代码（F5 或 F8 以单步执行）。如果您需要更多指导，请告诉我。
Sub CheckColors()
Dim rng As Range
For Each cel In Range("D2:D" & Range("D" & Rows.Count).End(xlUp).Row)
Set rng = Columns(1).Find(cel, lookat:=xlWhole)
If Not rng Is Nothing Then
cel.Interior.ColorIndex = rng.Interior.ColorIndex
cel.Offset(, 1).InteriorColorIndex = rng.Offset(, 1).Interior.ColorIndex
cel.Offset(, 2).InteriorColorIndex = rng.Offset(, 2).Interior.ColorIndex
End If
Next
End Sub
