Question

我需要使用VLOOKUP来复制单元格的颜色（不是CF）。我试图遵循LondonRob在线程中发布的vba代码 Vlookup to copy color of a cell - Excel VBA 但由于不精通vba，我遇到了麻烦。需要Vlookup，因为名称可以按不同的顺序排列。

我有一个示例工作表，其中需要根据名称和列号的vlookup将单元格颜色从第一个选项卡复制到第二个选项卡。我设置srcCell和destCell命名范围并将其复制到已发布的vba模块中。

第一个标签

名称Amt1

Kathy $ 500（细胞颜色为红色）

标记$ 350（单元格颜色为绿色）

第二个标签

名称Amt1 Amt2

标记$ 350 $ 200（绿色单元格需要350美元）

凯西500美元400美元（红色单元需要500美元）

有人可以帮忙吗？

Answer 1

如果您无法在Vlookup to copy color of a cell - Excel VBA了解解决方案，则可以尝试使用此解决方案：

默认情况下，它只使用Match来查找和复制带有值和格式的单元格。

FirstTab：

SecondTab：

运行宏后的SecondTab：

Sub copy_paste_with_format()

    Dim i As Long
    Dim var As Variant

    Dim FirstTab As Worksheet
    Dim SecondTab As Worksheet

    Set FirstTab = Application.Worksheets("FirstTab")
    Set SecondTab = Application.Worksheets("SecondTab")

    For i = 2 To 3
        var = Application.Match(SecondTab.Range("A" & i), FirstTab.Range("A:A"), 0)
        If Not IsError(var) Then
            FirstTab.Range("B" & var).Copy SecondTab.Range("B" & i)
        End If
    Next i

End Sub

Answer 2

基于此解决方案： How To Vlookup And Return Background Color Along With The Lookup Value In Excel?

修改后的代码以使用不同工作表中的vlookup源和目标，使用工作表中的自定义vlookup函数（称为函数LookupKeepColor），还添加了字体颜色。

' Put in the Worksheet of vlookup SOURCE values (in the sheet
' with the customized vlookup function)

Sub Worksheet_Change(ByVal Target As Range)
 Application.ScreenUpdating = False
'Vlookup and return value with font and interior color 
Dim I As Long
Dim xKeys As Long
Dim xDicStr As String
On Error Resume Next   
xKeys = UBound(xDic.Keys)
If xKeys >= 0 Then
    For I = 0 To UBound(xDic.Keys)
        xDicStr = xDic.Items(I)
        If xDicStr <> "" Then
            Worksheets("destination").Range(xDic.Keys(I)).Interior.Color = _
            Worksheets("source").Range(xDic.Items(I)).Interior.Color
            Worksheets("destination").Range(xDic.Keys(I)).Font.ColorIndex = _
            Worksheets("source").Range(xDic.Items(I)).Font.ColorIndex    
        Else
            Worksheets("destination").Range(xDic.Keys(I)).Interior.Color = xlNone
        End If
    Next
    Set xDic = Nothing
End If
Application.ScreenUpdating = True 
End Sub

用插入的工作表名称替换Worksheets("destination")
LookupKeepColor函数插入。将Worksheets("source")替换为您要查找的值。

使用LookupKeepColor(E2,$A$1:$C$8,3)

这样的语法替换工作表中的vlookup

通过工具>引用添加引用“ Microsoft Script Runtime”。

'Put in a Module
Public xDic As New Dictionary
Function LookupKeepColor(ByRef FndValue, ByRef LookupRng As Range, ByRef xCol As Long)
Dim xFindCell As Range
On Error Resume Next
Set xFindCell = LookupRng.Find(FndValue, , xlValues, xlWhole)
If xFindCell Is Nothing Then
    LookupKeepColor = ""
    xDic.Add Application.Caller.Address, ""
Else
LookupKeepColor = xFindCell.Offset(0, xCol - 1).Value
    xDic.Add Application.Caller.Address, xFindCell.Offset(0, xCol -1).Address
End If
End Function

Excel vba使用vlookup复制单元格的颜色

2 个答案: