Copy Source Formatting Of The Lookup Cell

[DHayes]

Good Day,
I need to do a lookup but I would like the format of the source to be the same as the destination. The formats are either number, currency or percentage.
I found an example here: How to copy source formatting of the lookup cell when using Vlookup in Excel?
I followed the instructions on this site but the moment I use the function as described excel seems to hang.
the first part of the code is:

Sub Worksheet_Change(ByVal Target As Range)
'Update by Extendoffice 20180706
    Dim I As Long
    Dim xKeys As Long
    Dim xDicStr As String
    On Error Resume Next
    Application.ScreenUpdating = False
    Application.CutCopyMode = 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.Items(I)).Copy
                Range(xDic.Keys(I)).PasteSpecial xlPasteFormats
            Else
                Range(xDic.Keys(I)).Interior.Color = xlNone
            End If
        Next
        Set xDic = Nothing
    End If
    Application.ScreenUpdating = True
    Application.CutCopyMode = True
End Sub

The second part of the code inserting a module is:

Public xDic As New Dictionary
'Update by Extendoffice 20180706
Function LookupKeepFormat(ByRef FndValue, ByRef LookupRng As Range, ByRef xCol As Long)
    Dim xFindCell As Range
    On Error Resume Next
    Application.ScreenUpdating = False
    Set xFindCell = LookupRng.Find(FndValue, , xlValues, xlWhole)
    If xFindCell Is Nothing Then
        LookupKeepFormat = " "
        xDic.Add Application.Caller.Address, " "
    Else
        LookupKeepFormat = xFindCell.Offset(0, xCol - 1).Value
        xDic.Add Application.Caller.Address, xFindCell.Offset(0, xCol - 1).Address
    End If
    Application.ScreenUpdating = True
End Function

The next step is: Click Tools > References. Then check the Microsoft Script Runtime box in the References – VBAProject dialog box
Once I insert the function

=LookupKeepFormat(E2,$A$1:$C$8,3)

Excel just hangs and does not do anything.
I am not a VBA expert and suspect there may be a better way to this.
Any assistance will greatly be appreciated.

 

[Yongle]

Are you trying to FORMAT a cell via a FORMULA in a cell ?
- Excel does not allow that

see https://support.microsoft.com/en-gb...n-of-limitations-of-custom-functions-in-excel

A user-defined function called by a formula in a worksheet cell cannot change the environment of Microsoft Excel. This means that such a function cannot do any of the following:

• Insert, delete, or format cells on the spreadsheet.
• Change another cell's value.
• Move, rename, delete, or add sheets to a workbook.
• Change any of the environment options, such as calculation mode or screen views.
• Add names to a workbook.
• Set properties or execute most methods.

 

[DHayes]

Thank you for your feedback it is appreciated.

 

[Fluff]

Excel is crashing, because the change event continually calls itself giving you a permanent loop.
Try adding these two lines & it should work.

Sub Worksheet_Change(ByVal Target As Range)
'Update by Extendoffice 20180706
    Dim I As Long
    Dim xKeys As Long
    Dim xDicStr As String
    On Error Resume Next
    Application.ScreenUpdating = False
    Application.CutCopyMode = False
    Application.EnableEvents = 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.Items(I)).Copy
                Range(xDic.Keys(I)).PasteSpecial xlPasteFormats
            Else
                Range(xDic.Keys(I)).Interior.Color = xlNone
            End If
        Next
        Set xDic = Nothing
    End If
    Application.ScreenUpdating = True
    Application.CutCopyMode = True
    Application.EnableEvents = True
End Sub

 

[DHayes]

Thank you Fluff that solved the problem of Excel crashing.
Have a great 2020.

 

[Fluff]

You're welcome & thanks for the feedback

 

[IrishChristof]

This is great thread, but is it possible to concatenate two different results on one cell? It only seems to keep one formatting. See example below, where J13 should show a black football icon and a red A, but it defaults to the format of the first part of the formula.

 

[Fluff]

As this is a totally different question from the op, you need to start a thread of your own. Thanks

 

[karunk]

Hi, Hoping to get some answers. I used the code from above to try and return the value with the same formatting but it still didn't work. I have a tab that contains the lookup data called "EUR ECON Data NUMERA (Mth) and then I have a "Graphs" tab where I want to dynamic pull various metrics (CPI, GDP, PPI, etc) into a graph when selected. I need the formatting to come over automatically since this will be going to senior leaders within the Organization as a type of dashboard. It did not get any error when I inputted the code but I wonder if it has something to do with the fact that I have Data on one tab and the lookup on another? I also have a match function to lookup the column number since that will change with the metric selected.
EUR Recession Dashboard

 

[Hcooper]

@Irishcristof - did you ever start a thread with yours and/or get any results? Your issue described in post #7 is exactly my issue.