Vlookup复制单元格的颜色 [英] Vlookup to copy color of a cell

问题描述

我有下表:

    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        ?

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

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.

推荐答案

在这里:

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

代码如下:

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

这篇关于Vlookup复制单元格的颜色的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！