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

Question

我一直在研究一个excel工具已有近一个星期了，因为我几乎已经完成了它，我发现自己面临着一个目前无法解决的问题。

在我的工作簿中的一张纸上，我有类似的内容：

现在我想使用sheet2对其进行颜色编码（用颜色填充单元格）以匹配它。所以你得到一个想法，这里的表2：

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

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

我试图编写一些代码来执行它，但遗憾的是它没有用。不过，你可以看看它可能会帮助你帮助我。

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