Vlookup复制单元格的颜色 - Excel VBA

Vlookup to copy color of a cell - Excel VBA

提问by CreamStat

I have the following tables:

我有以下表格：

    A       B     C     D
  1 Bob     1     6     Football
  2 Nate    3     7     Baseball
  3 Silver  3     2     Baseball
  4 Box     7     1     Cycling

A           D
Bob         ?

Nate        ?

I can successfully use Vlookup to fill the ?cells. For example, Vlookup(A8,A$1D$4,4,0). What I don′t know is to get Vlookup to copy the color too. There should be a solution in VBA. I hope your help.

我可以成功地使用 Vlookup 来填充?单元格。例如，Vlookup(A8,A$1D$4,4,0)。我不知道的是让 Vlookup 也复制颜色。VBA中应该有解决方案。我希望你的帮助。

回答by LondonRob

Here you go:

干得好：

1. Paste this code into a new module
2. Select the cells you'd like to format by VLOOKUP target
3. Run the macro formatSelectionByLookup

1. 将此代码粘贴到新模块中
2. 选择您要按 VLOOKUP 目标设置格式的单元格
3. 运行宏 formatSelectionByLookup

Here's the code:

这是代码：

Option Explicit
' By StackOverflow user LondonRob
' See http://stackoverflow.com/questions/22151426/vlookup-to-copy-color-of-a-cell-excel-vba

Public Sub formatSelectionByLookup()
  ' Select the range you'd like to format then
  ' run this macro
  copyLookupFormatting Selection

End Sub

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

Private Function extractDestRange(fromCell As Range) As Range
  ' Get the destination range of a vlookup in the formulat
  ' of fromCell. Returns fromCell itself if no vlookup is
  ' detected.
  Dim fromFormula As String
  Dim startPos As Integer
  Dim endPos As Integer
  Dim destAddr As String

  fromFormula = fromCell.Formula

  If Left(fromFormula, 9) = "=VLOOKUP(" Then
    startPos = InStr(fromFormula, ",") + 1
    endPos = InStr(startPos, fromFormula, ",")
    destAddr = Trim(Mid(fromFormula, startPos, endPos - startPos))
  Else
    destAddr = fromCell.Address
  End If
  Set extractDestRange = fromCell.Parent.Range(destAddr)

End Function

Private Function extractLookupColNum(fromCell As Range) As Integer
  ' If fromCell contains a vlookup, return the number of the
  ' column requested by the vlookup. Otherwise return 1
  Dim fromFormula As String
  Dim startPos As Integer
  Dim endPos As Integer
  Dim colNumber As String

  fromFormula = fromCell.Formula

  If Left(fromFormula, 9) = "=VLOOKUP(" Then
    startPos = InStr(InStr(fromFormula, ",") + 1, fromFormula, ",") + 1
    endPos = InStr(startPos, fromFormula, ",")
    If endPos < startPos Then
      endPos = InStr(startPos, fromFormula, ")")
    End If
    colNumber = Trim(Mid(fromFormula, startPos, endPos - startPos))
  Else
    colNumber = 1
  End If

  extractLookupColNum = colNumber

End Function

Private Function getNthColumn(fromRange As Range, n As Integer) As Range
  ' Get the Nth column from fromRange
  Dim startCell As Range
  Dim endCell As Range

  Set startCell = fromRange(1).Offset(0, n - 1)
  Set endCell = startCell.End(xlDown)

  Set getNthColumn = Range(startCell, endCell)

End Function