Question

我觉得之前已经问过这个问题，但我并不是真的了解这些解决方案。我想知道如何检查一些单元格的值并复制那些与另一个单元格匹配的颜色。我有一个看起来像这样的工作表：

   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

A，B和C中的某些值具有不同的颜色以将其标记为特殊（背景颜色，而不是字体颜色）。我需要从D列中取值，在A中找到匹配，然后如果/当我找到匹配时，将背景颜色从A，B和C复制到D，E和F的背景。如果我找到D到匹配（如第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

我不确定自己要做什么。任何人都可以提供解决方案和解释吗？

Answer 1

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

抱歉没有时间立即解释，但我认为这样做会。你应该使用比魔术专栏3,4,5等更好的东西，但这是一个快速解决方案。

Answer 2

这应该有效。它可以提高效率，但它肯定会让你开始。

将其放入标准模块并运行代码（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

Excel：检查单元格中的值和复制颜色

2 个答案: