VBA 与 VLOOKUP 一起使用的宏错误

Question

我最近使用了来自@LondonRob 的 post 的代码，它允许在使用 VLOOKUP 时单元格的格式与包含的数据一起使用。

原始问题 - Vlookup to copy color of a cell - Excel VBA

这很好，适用于大多数值。不幸的是，某些值无法传递格式，我收到错误消息：

Run-time error "13": Data mismatch

我已经删除了所有空单元格，并通过反复试验删除了所有公式错误并更正了拼写错误。尝试运行宏时仍有一些单元格会弹出此消息。

我在数据中看不到任何错误，并且此错误在单元格中的出现似乎几乎是随机的。数据集也很大，所以即使找到所有有问题的单元格也很困难（我找到了几个）。

我本来会对该主题发表评论，但此时我没有名气。

使用的编码是（虽然在我的模块中我去掉了前6行）-

Option Explicit
' By Whosebug user LondonRob
' See 

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

谢谢

Answer 1

那里有很多代码，因此很难说出确切的问题可能是什么。

试试这个版本：

Sub tester()
    Dim c As Range
    If TypeName(Selection)<>"Range" Then Exit Sub
    For Each c In Selection
        CopySourceFormats c
    Next c
End Sub


'If the passed cell has a VLOOKUP formula,
'  extract the arguments and find the source of the return value.
'Copy formatting from that cell to the cell with the formula
Sub CopySourceFormats(c As Range)
    Dim arr, v, rng As Range, col As Long, f As String
    Dim m, fs As Font, fd As Font, rngSrc As Range

    'skip any unwanted cells
    f = c.Formula
    If Not f Like "=VLOOKUP(*" Then Exit Sub
    If IsError(c.Value) Then Exit Sub 'no "source" cell to find



    'Extract just the arguments and create an array 
    '  (assumes no arguments contain a comma: 
    '  would need better parsing otherwise)
    f = Replace(f, "=VLOOKUP(", "")
    f = Left(f, Len(f) - 1)
    arr = Split(f, ",")

    v = c.Parent.Evaluate(arr(0)) 'get lookup value
    Set rng = Evaluate(arr(1))    'source table (could be on another sheet)
    col = CLng(arr(2))            'column number in lookup table

    'Debug.Print v, rng.Address(), col

    'Try to match the value in the first column of the lookup table
    m = Application.Match(v, rng.Columns(1), 0)

    'Got a match? Copy formatting for the "source" cell
    If Not IsError(m) Then
        Set rngSrc = rng.Cells(m, col)
        Set fs = rngSrc.Font
        Set fd = c.Font
        'copy formatting: add/subtract properties to suit...
        fd.Size = fs.Size
        fd.Color = fs.Color
        fd.Bold = fs.Bold
        c.Interior.ColorIndex = rngSrc.Interior.ColorIndex
    End If
End Sub

VBA 与 VLOOKUP 一起使用的宏错误

VBA Macro Error used with VLOOKUP

excel

vba

vlookup