Lookup return cell format

[Inkz]

Hi everyone,

*Reposted as I had replied to my previous post with the code which possibly made the post go under the radar*

I have been looking for a vba code that creates a lookup function that returns cell formats.

I have a sheet with a list of color names in column A and color formats in column B. This sheet is called "Data".
In a different sheet called "Working sheet", which is in the same workbook, I would like to choose a color name from a data validation list and then have the lookup function return the corrosponding color format in the cell next to the name.

I have found the code below and inserted it as a module and enabled "Microsoft scripting runtime" under references, but I cant make it work. Can anyone explain if the code should work and if so what I need to do differently?

Thank you in advance.


Public xDic As New Dictionary
Public strWB As String
Public strWS As String

Function CLookup(ByRef FndValue, ByRef LookupRng As Range, ByRef xCol As Long)
Dim xFindCell As Range
On Error Resume Next

strWB = LookupRng.Test.xlsm '*** Remember the Workbook where the data and color are coming from
strWS = LookupRng.Data '*** Remember the Worksheet where the data and color are coming from

Set xFindCell = LookupRng.Find(FndValue, , xlValues, xlWhole)

If xFindCell Is Nothing Then
CLookup = ""
xDic.Add Application.Caller.Address, ""
Else
CLookup = xFindCell.Offset(0, xCol - 1).Value
xDic.Add Application.Caller.Address, xFindCell.Offset(0, xCol - 1).Address

End If
End Function

Sub Worksheet_Change(ByVal Target As Range)
Dim I As Long
Dim xKeys As Long
Dim xDicStr As String
Dim rngLoc As Range
On Error Resume Next
Application.ScreenUpdating = False
xKeys = UBound(xDic.Keys)
If xKeys >= 0 Then
For I = 0 To UBound(xDic.Keys)
xDicStr = xDic.Items(I)
If xDicStr <> "" Then
Range(xDic.Keys(I)).Interior.Color = Application.Workbooks(strWB).Worksheets(strWS).Range(xDic.Items(I)).Interior.Color
Else
Range(xDic.Keys(I)).Interior.Color = xlNone
End If
Next
Set xDic = Nothing
End If
Application.ScreenUpdating = True
End Sub

[AliGW]

Administrative Note:

We would very much like to help you with your query, however you need to include code tags around your code.

Please take a moment to add the tags. Posting code between [code]Please [url=https://www.excelforum.com/login.php]Login or Register [/url] to view this content.[/code] tags makes your code much easier to read and copy for testing, and it also maintains VBA formatting.

Please see Forum Guideline #2 about code tags and adjust accordingly. Click on Edit to open your post, then highlight your code and click the # icon at the top of your post window. More information about these and other tags can be found here.

[AliGW]

Administrative Note:

Unfortunately, this is a duplicate thread, and you are allowed only ONE thread per issue here.

Please see Forum Rule #2 about thread duplication.

I am closing this thread, but you may continue here in the original thread: https://www.excelforum.com/excel-pro...-workbook.html

Thread closed.