在具有值的单元格内进行VBA交叉工作表颜色编码匹配

我已经做了近一个星期的Excel工具了，而且几乎到了最后，我发现自己面临着一个我目前无法解决的问题。

在我的工作簿中的一张纸上，我有这样的东西：

现在我想用颜色代码（用颜色填充单元格）来匹配它。 所以你有一个想法，这里是sheet2：

因此，sheet1中的行将通过检查sheet2上的相应A列进行颜色编码。 例如：如果单元格A2表示ABC，我希望macros填充第2行中具有黄色值的所有单元格（您可以在F1中看到：Sheet3中的G3，ABC表示黄色）。

所以最后应该看起来像这样：

我试图写一些代码，不幸的是它没有工作。 尽pipe如此，你可以看看它可能会帮助你。

Sub colormatching() Dim wsSource As Worksheet Dim wsTarget As Worksheet Dim aCol As Long Dim MaxRowList As Long, destiny_row As Long, x As Long Set wsSource = ThisWorkbook.Worksheets("Sheet1") Set wsTarget = ThisWorkbook.Worksheets("Sheet2") aCol = 1 MaxRowList = wsSource.Cells(Rows.Count, aCol).End(xlUp).Row destiny_row = 1 For x = 2 To MaxRowList If InStr(1, wsTarget.Cells(x, 1), "ABC") > 0 Then wsSource.Range("$A$" & x).Select With Selection.Interior .Pattern = xlSolid .PatternColorIndex = xlAutomatic .Color = 65535 .TintAndShade = 0 .PatternTintAndShade = 0 End With destiny_row = destiny_row + 1 End If Next End Sub 

我会非常感激这个帮助！ 提前致谢。

Answer 1

你可以试试这个：

 Sub main() Dim cell As Range With ThisWorkbook.Worksheets("Sheet1") .UsedRange.Interior.ColorIndex = xlNone '<--| clear preceeding cells coloring For Each cell In Intersect(.Columns(1), .UsedRange.SpecialCells(xlCellTypeConstants).EntireRow) cell.EntireRow.SpecialCells(xlCellTypeConstants).Interior.ColorIndex = GetColorIndex(cell.row) Next End With End Sub Function GetColorIndex(rowIndex As Long) As Variant With ThisWorkbook.Worksheets("Sheet2") GetColorIndex = .Range("F1:F3").Find(what:=.Cells(rowIndex, 1), LookIn:=xlValues, lookat:=xlWhole).Offset(, 1).Interior.ColorIndex End With End Function