Visual Basic Code that does a Vlookup but retains formatting

[dab448]

Hi Everyone,

I am trying to basically do a Vlookup that can retain the font color and formatting. But as you can't do this with a Vlookup function, I need a Visual Basic function that can do this.

Can anyone help?

Thank you!!
Danielle

 

[StephenCrump]

Welcome to the Forum!

Do you mean something like this?

Excel 2010

	A	B
1	A	23
2	B	45
3	C	67
4	D	89
5
6	Lookup
7	B	45

<tbody>
</tbody>

1
​

Private Sub Worksheet_Change(ByVal Target As Range)

    Dim rngLookupCell As Range, rngLookupTable As Range
    Dim lRow As Long
    
    Set rngLookupCell = Range("A7")
    If Intersect(Target, rngLookupCell) Is Nothing Then Exit Sub
    Set rngLookupTable = Range("A1:B4")
    
    On Error Resume Next
    lRow = WorksheetFunction.Match(rngLookupCell.Value, rngLookupTable.Columns(1), 0)
    On Error GoTo 0
    With rngLookupCell.Offset(, 1)
        If lRow = 0 Then
            .Clear
            .Value = CVErr(xlErrNA)
        Else
            rngLookupTable.Cells(lRow, 2).Copy .Cells(1, 1)
        End If
    End With
        
End Sub

 

[Danielleb]

Hi Stephen,

Thank you for your help.

Yes, that is what I'm looking to do, but I want it as a function. Would you happen to know how to do this?

Thanks!
Danielle

 

[StephenCrump]

Yes, that is what I'm looking to do, but I want it as a function.

Yes, I thought that's where we were headed. The stock answer here is that you can't use a UDF to change a worksheet, including formatting.

But you can work around it. Try the code below, using VLookupFormat where you would normally use VLookup.

This code was originally posted by Jerry Sullivan in #18 here: http://www.mrexcel.com/forum/excel-...lications-vlookup-keep-cell-formatting-2.html

Jerry attributed it to a clever workaround that Mike Erickson has shared.

'In the ThisWorkbook Code Module
Public FormatSource As New Collection
Public FormatTarget As New Collection
Private Sub Workbook_SheetCalculate(ByVal Sh As Object)
   
   Dim rSource As Range, rOneTarget As Range

   On Error GoTo Reset
   
   For Each rOneTarget In FormatTarget
      Set rSource = FormatSource(rOneTarget.Address(, , , True))
      
      With rOneTarget
         With .Interior
            .ColorIndex = rSource.Interior.ColorIndex
         End With
         
         With .Font
            .ColorIndex = rSource.Font.ColorIndex
            .Bold = rSource.Font.Bold
            .Italic = rSource.Font.Italic
            .Size = rSource.Font.Size
         End With
      End With
   Next rOneTarget

Reset:
   Set ThisWorkbook.FormatSource = New Collection
   Set ThisWorkbook.FormatTarget = New Collection

End Sub
'In a standard code module
Function VlookupFormat(sLookupValue As String, rTableRange As Range, _
   iColIndexNum As Long, Optional bRangeLookup = True) As Variant
   
    Dim cThisCell As Range, cFound As Range
    Dim vRow As Variant
    
    Application.Volatile '--optional
    
    On Error GoTo ErrorValue
    If rTableRange.Columns.Count < iColIndexNum Then
        VlookupFormat = CVErr(xlErrRef)
        Exit Function
    End If
    
    With Application
       Set cThisCell = Application.Caller
    
       vRow = .Match(sLookupValue, .Index(rTableRange, 0, 1), _
          bRangeLookup)
    
       If IsError(vRow) Then
          VlookupFormat = CVErr(xlErrNA)
       Else
          Set cFound = .Index(rTableRange, vRow, _
             iColIndexNum)
          VlookupFormat = cFound.Value
          ThisWorkbook.FormatTarget.Add Item:=cThisCell, _
             Key:=cThisCell.Address(, , , True)
          ThisWorkbook.FormatSource.Add Item:=cFound, _
             Key:=cThisCell.Address(, , , True)
       End If
    End With
    Exit Function

ErrorValue:
    VlookupFormat = CVErr(xlErrValue)

End Function

 

[Danielleb]

Yes, I thought that's where we were headed. The stock answer here is that you can't use a UDF to change a worksheet, including formatting.

But you can work around it. Try the code below, using VLookupFormat where you would normally use VLookup.

This code was originally posted by Jerry Sullivan in #18 here: http://www.mrexcel.com/forum/excel-...lications-vlookup-keep-cell-formatting-2.html

Jerry attributed it to a clever workaround that Mike Erickson has shared.

'In the ThisWorkbook Code Module
Public FormatSource As New Collection
Public FormatTarget As New Collection
Private Sub Workbook_SheetCalculate(ByVal Sh As Object)
   
   Dim rSource As Range, rOneTarget As Range

   On Error GoTo Reset
   
   For Each rOneTarget In FormatTarget
      Set rSource = FormatSource(rOneTarget.Address(, , , True))
      
      With rOneTarget
         With .Interior
            .ColorIndex = rSource.Interior.ColorIndex
         End With
         
         With .Font
            .ColorIndex = rSource.Font.ColorIndex
            .Bold = rSource.Font.Bold
            .Italic = rSource.Font.Italic
            .Size = rSource.Font.Size
         End With
      End With
   Next rOneTarget

Reset:
   Set ThisWorkbook.FormatSource = New Collection
   Set ThisWorkbook.FormatTarget = New Collection

End Sub
'In a standard code module
Function VlookupFormat(sLookupValue As String, rTableRange As Range, _
   iColIndexNum As Long, Optional bRangeLookup = True) As Variant
   
    Dim cThisCell As Range, cFound As Range
    Dim vRow As Variant
    
    Application.Volatile '--optional
    
    On Error GoTo ErrorValue
    If rTableRange.Columns.Count < iColIndexNum Then
        VlookupFormat = CVErr(xlErrRef)
        Exit Function
    End If
    
    With Application
       Set cThisCell = Application.Caller
    
       vRow = .Match(sLookupValue, .Index(rTableRange, 0, 1), _
          bRangeLookup)
    
       If IsError(vRow) Then
          VlookupFormat = CVErr(xlErrNA)
       Else
          Set cFound = .Index(rTableRange, vRow, _
             iColIndexNum)
          VlookupFormat = cFound.Value
          ThisWorkbook.FormatTarget.Add Item:=cThisCell, _
             Key:=cThisCell.Address(, , , True)
          ThisWorkbook.FormatSource.Add Item:=cFound, _
             Key:=cThisCell.Address(, , , True)
       End If
    End With
    Exit Function

ErrorValue:
    VlookupFormat = CVErr(xlErrValue)

End Function

Hi Stephen,

Thanks for your help but that formula gives me some error about being in a circular loop.

Do you know how to correct this?

Thanks,
Danielle

 

[StephenCrump]

Thanks for your help but that formula gives me some error about being in a circular loop.

Hmm, it's not immediately obvious why that should be.

Have a look at the sample workbook here: https://app.box.com/s/ovpumc8wozkop40ef616rcqv20s2hdn7

 

[Danielleb]

Hmm, it's not immediately obvious why that should be.

Have a look at the sample workbook here: https://app.box.com/s/ovpumc8wozkop40ef616rcqv20s2hdn7

Hi Stephen,

Thank you for your response.

I should have given further details when I initially asked the question but I am looking for a Visual Basic function that would retain all of the font colors where, for example, half of the sentence is in black font and the other half of the sentence is in red font. Do you happen to know how to amend the VB code that you sent me so that it would retain all of the font colors, even when one cell has more than one font color?

The current code is making the entire cell's font color either red or black, but is not retaining multiple font colors when pulling over the data.

Thanks for all of your help, it's greatly appreciated!

Thanks,
Danielle

 

[StephenCrump]

I should have given further details when I initially asked the question but I am looking for a Visual Basic function that would retain all of the font colors where, for example, half of the sentence is in black font and the other half of the sentence is in red font. Do you happen to know how to amend the VB code that you sent me so that it would retain all of the font colors, even when one cell has more than one font color?

The current code is making the entire cell's font color either red or black, but is not retaining multiple font colors when pulling over the data.

Unfortunately, you've hit a roadblock with this one ...

If your cell contains a formula, e.g. =VLookupFormat( ... ), then you can only apply one format to the entire cell contents.

If you want to allow multiple formats, you'll need to lose the formula, and use an approach such as in Post #2.

 

[Danielleb]

Hi Stephen,

Thanks for your response.

How can I amend the code in post #2 so that it can be run for multiple cells at the same time? I believe a loop is required, but I am not sure how to write this code in Visual Basic.

Thanks again,
Danielle

 

[StephenCrump]

Try:

Private Sub Worksheet_Change(ByVal Target As Range)

    Dim rngMonitored As Range, rngToCheck As Range, rngLookupTable As Range, rng As Range
    Dim lRow As Long
    Const R_OFFSET = 0
    Const C_OFFSET = 1  'put result one column to the right, say
    Const LOOKUP_COL = 2
    
    Set rngLookupTable = Range("A1:B4") 'say
    Set rngMonitored = Range("A7:A10")  'say
    Set rngToCheck = Intersect(Target, rngMonitored)
    
    If Not rngToCheck Is Nothing Then
        Application.EnableEvents = False
        For Each rng In rngToCheck
            On Error Resume Next
            lRow = WorksheetFunction.Match(rng.Value, rngLookupTable.Columns(1), 0)
            On Error GoTo 0
            With rng.Offset(R_OFFSET, C_OFFSET)
                If lRow = 0 Then
                    .Clear
                    .Value = CVErr(xlErrNA)
                Else
                    rngLookupTable.Cells(lRow, LOOKUP_COL).Copy .Cells(1, 1)
                End If
            End With
        Next rng
    End If
    
    Application.EnableEvents = True

End Sub