Sep 19 2020 07:12 AM
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