[英]VBA Macro Error used with VLOOKUP
我最近使用了來自@LondonRob的帖子中的代碼,它允許在使用VLOOKUP時將包含數據的單元格格式轉移。
原始問題 - 復制單元格顏色的Vlookup - Excel VBA
這很好,適用於大多數價值觀。 不幸的是,有些值無法傳輸格式,我收到錯誤:
運行時錯誤“13”:數據不匹配
我已經取出所有空單元格並通過反復試驗取出任何公式錯誤並糾正錯誤拼寫。 嘗試運行宏時,仍然有一些單元格會顯示此消息。
我看不到數據中的任何錯誤,並且單元格中出現此錯誤似乎幾乎是隨機的。 數據集也很龐大,因此即使找到所有有問題的單元也很難(我找到了一些)。
我會評論這個帖子,但我現在還沒有聲譽。
使用的編碼是(雖然在我的模塊中我拿出前6行) -
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
謝謝
那里有很多代碼,所以很難說確切的問題是什么。
試試這個版本:
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
聲明:本站的技術帖子網頁,遵循CC BY-SA 4.0協議,如果您需要轉載,請注明本站網址或者原文地址。任何問題請咨詢:yoyou2525@163.com.