Question

我有主数据表，其属性ID是唯一的和单位。我有另一个表，我在其中添加与属性关联的产品值。

如果单位基于属性ID匹配，则单元格将以绿色突出显示，否则为红色。

为了实现上述目标，我已经编写了一些基本代码，但它似乎没有用。 vlookup正常工作，但使用vba它只是退出。请参阅下面的图片和代码。列a和b包含属性主数据，列d到g包含产品属性值。

EG。对于乘积p1，值“IN”对属性“A1”有效，但“m”无效。此外，每个属性可以有多个以逗号分隔的单位。需要帮助解决问题。

代码：

Sub UnitCheck()


Dim AttrIDrange As range, AttrIDcell As range
Dim attrID
Dim Lookup_Range As range
Dim I, J As Variant
Dim UNIT As Variant
Set Lookup_Range = range("A2:B4")

Set AttrIDrange = range("E1:G1")


For Each AttrIDcell In AttrIDrange
attrID = AttrIDcell.Value


For I = 2 To 3
For J = 5 To 7

If Application.WorksheetFunction.VLookup(attrID, Lookup_Range, 2, False) = UNIT Then
    Worksheets("Sheet4").Cells(I, J).Font.Color = vbGreen

    Else
     Worksheets("Sheet4").Cells(I, J).Font.Color = vbRed
    End If
Next
Next
Next

End Sub

新方案： 如果为任何属性定义了多个单位，那么即使产品值中只有1个单位，也应该以绿色高亮显示。如果1是正确的并且休息不正确，那么因为它是部分正确的，所以它应该以红色或黄色突出显示。请看图片。需要这种情况的帮助。

Scenario 2 Image

Answer 1

在I和J循环中循环时，您需要将 UNIT 设置为某些内容，然后才能将其与从工作表VLOOKUP function传回的结果进行比较。

Sub UnitCheck()
    Dim AttrIDrange As Range, AttrIDcell As Range
    Dim attrID
    Dim Lookup_Range As Range
    Dim I As Long, J As Long
    Dim UNIT As Variant
    Dim bCHECK_P1

    With Worksheets("Sheet4")
        bCHECK_P1 = False
        Set Lookup_Range = .Range("A2:B4")
        Set AttrIDrange = .Range("E1:G1")

        For Each AttrIDcell In AttrIDrange  '.Range("E1:G1")
            attrID = AttrIDcell.Value

            For I = 2 To 3
                UNIT = AttrIDcell.Offset(I - 1, 0).Value  '<~~ set UNIT here!
                For J = 5 To 7
                    .Cells(I, J).Font.Color = xlAutomatic
                    If Application.WorksheetFunction.VLookup(attrID, Lookup_Range, 2, False) = UNIT Then
                        .Cells(I, J).Font.Color = vbGreen
                    Else
                         .Cells(I, J).Font.Color = vbRed
                    End If
                Next
            Next
        Next
    End With

End Sub

Answer 2

我认为这是OP所要求的。此外，这会将三For/next和VLookUp替换为希望更适合的字典。

关于OP，我看到两个基本问题，UNIT从未被分配，但是，听起来=运算符不正确...相反，它听起来像一个查找值必须是已确认以逗号分隔的字符串存在。下面的代码使用InStr来检查查找值是否存在。

Sub UnitCheck()
Application.ScreenUpdating = False

Dim UNIT As String
Dim R, c, AttrID   As Integer
Dim ProdRange, ProdCell As Range
Set ProdRange = Range("E2:G4")

'Assign LookUp values to array
Dim LookUpArray(), ProdAttrIDArray() As Variant
LookUpArray = Range("A2:B4").Value2

'Create dictionary from Lookup values
Set D = CreateObject("Scripting.Dictionary")
For R = 1 To UBound(LookUpArray)
    D.Add LookUpArray(R, 1), LookUpArray(R, 2)
Next

'Loop through product table
For Each ProdCell In ProdRange
    'Get attribute ID from row 1 of corresponding column
    AttrID = Cells(1, ProdCell.Column).Value2
    If D(AttrID) <> Empty Then
        'If AttrID found in LookUp Dictionary then get UNIT from it
        UNIT = D(AttrID)
        'If UNIT found in product cell then color cell green, else red
        If (InStr(1, ProdCell.Value2, UNIT) > 0) Then
            ProdCell.Interior.Color = vbGreen
        Else
            ProdCell.Interior.Color = vbRed
        End If
    End If
Next

End Sub

结果就是这个

新方案

好的，我认为这将涵盖您的新方案。请注意，我还添加了Trim()和VBTextCompare，以便忽略空格并且比较不区分大小写。我不确定你是否想要这种行为。另外，请注意单位的顺序无关紧要。例如，“IN，km”匹配“KM，IN”，因为忽略空格，忽略大写，并忽略顺序。

Sub UnitCheck()
    Application.ScreenUpdating = False

    Dim UNIT, PUnits() As String
    Dim r, c, AttrID, i, n As Integer
    Dim ProdRange, ProdCell As Range
    Set ProdRange = Range("E2:G3")

    'Assign LookUp values to array
    Dim LookUpArray(), ProdAttrIDArray() As Variant
    LookUpArray = Range("A2:B4").Value2

    'Create dictionary from Lookup values
    Set D = CreateObject("Scripting.Dictionary")
    For r = 1 To UBound(LookUpArray)
        D.Add LookUpArray(r, 1), LookUpArray(r, 2)
    Next

    'Loop through product table
    For Each ProdCell In ProdRange
        'Get attribute ID from row 1 of correspdniong column
        AttrID = Cells(1, ProdCell.Column).Value2
        If D(AttrID) <> Empty Then
            'If AttrID found in LoopUp Dictionary then get UNIT from it
            UNIT = D(AttrID)
            PUnits = Split(ProdCell.Value2, ",")
            'reset counter
            n = 0
            'Count the number of product units found in the lookup value
            For i = 0 To UBound(PUnits)
                If InStr(1, Trim(UNIT), Trim(PUnits(i)), vbTextCompare) > 0 Then
                    n = n + 1
                End If
            Next
            'prevent division by zero
            If i = 0 Then i = 1
            'select action based on percent matched
            Select Case n / i
                Case Is >= 1
                    ProdCell.Interior.Color = vbGreen
                Case Is > 0
                     ProdCell.Interior.Color = vbYellow
                Case Else
                    ProdCell.Interior.Color = vbRed
            End Select

        End If
    Next
End Sub

Excel中的VLookup vba无法正常工作

2 个答案:

新方案