与 VLOOKUP 一起使用的 VBA 宏错误 [英] VBA Macro Error used with VLOOKUP
问题描述
我最近使用了@LondonRob 的帖子中的代码,它允许在使用 VLOOKUP 时将单元格的格式与包含的数据一起传递.
I recently used code from a post by @LondonRob, which allows the format of a cell to be carried over with the containing data when using VLOOKUP.
原始问题 - Vlookup 复制单元格的颜色 -Excel VBA
这很棒并且适用于大多数值.不幸的是,某些值无法采用该格式,并且我收到错误消息:
This is great and works for the majority of values. Unfortunately some values can't have the format carried across and I receive the error:
运行时错误13":数据不匹配
Run-time error "13": Data mismatch
我删除了所有空单元格,并通过反复试验删除了所有公式错误并更正了拼写错误.尝试运行宏时,仍有一些单元格显示此消息.
I have taken out all empty cells and by trial and error taken out any formula errors and corrected misspellings. There are still a few cells bring this message up when trying to run the macro.
我在数据中看不到任何错误,并且单元格中出现此错误似乎几乎是随机的.数据集也很大,所以即使找到所有有问题的细胞也很困难(我已经找到了一些).
I can't see any errors in the data, and the occurrence of this error in cells appears to be almost random. The data set is also huge, so even finding all the problematic cells is proving difficult (I have located a few).
我会在该线程上发表评论,但此时我没有声誉.
I would have commented on the thread, but I don't have the reputation at this point.
使用的编码是(虽然在我的模块中我去掉了前 6 行)-
The coding used is (though in my module I took out the first 6 lines) -
Option Explicit
' By StackOverflow user LondonRob
' See https://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
谢谢
推荐答案
代码很多,所以很难说到底是什么问题.
There's a lot of code there, so it's difficult to say what the exact issue might be.
试试这个版本:
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
这篇关于与 VLOOKUP 一起使用的 VBA 宏错误的文章就介绍到这了,希望我们推荐的答案对大家有所帮助,也希望大家多多支持IT屋!