vlookup to copy color of a cell - wrong format ret

Question

I'm using the macro @LondonRob posted in this SO question

I'm having an issue that if a value repeats, it pulls the color of the original incident rather than the actual looked up value. So if Item1 holds a value in column C of 1.27 and font color pink, and item4 holds a value in column C of 1.27 and font color blue, when I run the macro on the vlookup item4's 1.27 it will be colored pink rather than blue.

The key bit of code is here:

    Private Sub copyLookupFormatting(destRange As Range)
  ' Take each cell in destRange and copy the formatting
  ' from the destination cell (either itself or
  ' the vlookup target if the cell is a vlookup)
  Dim destCell As Range
  Dim srcCell As Range

  For Each destCell In destRange
    Set srcCell = getDestCell(destCell)
    copyFormatting destCell, srcCell
  Next destCell

End Sub

Private Sub copyFormatting(destCell As Range, srcCell As Range)
  ' Copy the formatting of srcCell into destCell
  ' This can be extended to include, e.g. borders
  destCell.Font.Color = srcCell.Font.Color
  destCell.Font.Bold = srcCell.Font.Bold
  destCell.Font.Size = srcCell.Font.Size

  destCell.Interior.Color = srcCell.Interior.Color

End Sub

Private Function getDestCell(fromCell As Range) As Range
  ' If fromCell is a vlookup, return the cell
  ' pointed at by the vlookup. Otherwise return the
  ' cell itself.
  Dim srcColNum As Integer
  Dim srcRowNum As Integer
  Dim srcRange As Range
  Dim srcCol As Range

  srcColNum = extractLookupColNum(fromCell)
  Set srcRange = extractDestRange(fromCell)
  Set srcCol = getNthColumn(srcRange, srcColNum)
  srcRowNum = Application.Match(fromCell.Value, srcCol, 0)
  Set getDestCell = srcRange.Cells(srcRowNum, srcColNum)

End Function

Answer 1

The problem is with Application.Match which stops at the first instance of any non-unique values. You should use a column with unique values to search against.

The first column should be unique if you're using it for a vlookup so try replacing the getDestCell function with:

Private Function getDestCell(fromCell As Range) As Range
  ' If fromCell is a vlookup, return the cell
  ' pointed at by the vlookup.
  ' Otherwise return the cell itself.

    Set getDestCell = fromCell

    Dim VLUData() As String

    Dim srcRow As Double, srcCol As Double
    Dim VLUTable As Range

    If Left(fromCell.Formula, 9) = "=VLOOKUP(" Then
        VLUData() = Split(Mid(fromCell.Formula, 10, _
            Len(fromCell.Formula) - 10), ",")
        Set VLUTable = Range(VLUData(1))
        srcRow = Application.WorksheetFunction.Match _
            (Range(VLUData(0)).Value, VLUTable.Columns(1), 0)
        srcCol = VLUTable.Columns(Val(VLUData(2))).Column
        Set getDestCell = Cells(srcRow, srcCol)
    End If

End Function

The support functions extractLookupColNum, extractDestRange and getNthColumn can also be deleted as the array VLUData is filled with the VLookup arguments and can be manipulated directly in the function for unique matching if further necessary.

Also - to allow copying of 'no fill' cells correctly, edit the copyFormatting Sub to:

Private Sub copyFormatting(destCell As Range, srcCell As Range)
  ' Copy the formatting of srcCell into destCell
  ' This can be extended to include, e.g. borders
  destCell.Font.Color = srcCell.Font.Color
  destCell.Font.Bold = srcCell.Font.Bold
  destCell.Font.Size = srcCell.Font.Size

  If destCell.Address <> srcCell.Address Then _
     destCell.Interior.Color = srcCell.Interior.Color
  If srcCell.Interior.ColorIndex = xlNone Then _
     destCell.Interior.ColorIndex = xlNone

End Sub