LookupKeepColor functionality is not working when source & destination sheets are different

Copper Contributor

Dear Team,

My requirement is to fetch the value along with its formatting from the source sheet cell to the destination sheet cell. 

I used LookupKeepColor functionality. Eventhough it is working when the source & destination sheet is same, but it fails when the destination sheet is different.

Note: Source worksheet -> "14SEP"; Destination worksheet-> "Analysis"

Give below is the process i followed -

 

Step1. In the worksheet contains the value you want to vlookup, right-click the sheet tab and select View Code from the context menu.
Step2. In the opening Microsoft Visual Basic for Applications window, please copy below VBA code into the Code window.


VBA code 1: Vlookup and return background color with the lookup value

 

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("Analysis").Range(xDic.Keys(I)).Interior.Color = _
Worksheets("14SEP").Range(xDic.Items(I)).Interior.Color
Worksheets("Analysis").Range(xDic.Keys(I)).Font.ColorIndex = _
Worksheets("14SEP").Range(xDic.Items(I)).Font.ColorIndex
Else
Worksheets("Analysis").Range(xDic.Keys(I)).Interior.Color = xlNone
End If
Next
Set xDic = Nothing
End If
Application.ScreenUpdating = True
End Sub

 

 

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

 

Add Reference 'Microsoft Script Runtime' by Tools > References

 

0 Replies