VBA Code to keep source formatting with VLookup

_MS_

New Member
Joined
Aug 27, 2020
Messages
1
Office Version
  1. 365
Platform
  1. Windows
Hi!

I am using VLOOKUP to lookup value (Worksheet "Criteria") from another worksheet ("Criteria Lookup"). I would like to match the source formatting (or at least the cell color).

I have tried several codes I found in other forums, but I can't get it to work. The closest I found is the one below, but I get the #value! error. I am new to vba so I'm not sure how to replace the naming properly o_O

Can anyone help?

Thanks in advance!!

VBA Code:
' 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


Replace Worksheets("destination")with the sheet name that you inserted the
LookupKeepColor Function into. Replace Worksheets("source") with values you are looking up.

Replace vlookup in the sheet with the syntax like LookupKeepColor(E2,$A$1:$C$8,3)

Add Reference 'Microsoft Script Runtime' by Tools > References.

VBA Code:
'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
 

Some videos you may like

Excel Facts

Excel Joke
Why can't spreadsheets drive cars? They crash too often!

Watch MrExcel Video

Forum statistics

Threads
1,118,807
Messages
5,574,427
Members
412,592
Latest member
moonsugar
Top