excel A列中未Map到B列的项的VBA警报

beq87vna  于 2023-01-21  发布在  其他
关注(0)|答案(1)|浏览(141)

日安。我有一个表,有2列A和B。我想知道,如果有多少在项目中列A和没有Map到列B,并显示它,如果这些项目是什么。谢谢你这么多。

omvjsjqw

omvjsjqw1#

返回不匹配的项目

电子表格

平淡

=UNIQUE(FILTER(A2:A21,ISNA(XMATCH(A2:A21,B2:B21))))

=LET(vCol,A2:A21,lCol,B2:B21,fInc,ISNA(XMATCH(vCol,lCol)),
    UNIQUE(FILTER(vCol,fInc)))

LET变量

vCol - Value Column
lCol - Lookup Column
fInc - Filter Include

VBA语言

板材模块,例如Sheet1

Private Sub Worksheet_Activate()
    CheckMappings Me
End Sub

其余部分进入一个或多个标准模块,例如Module1
简单测试

Sub CheckMappingsTEST()
    Dim ws As Worksheet: Set ws = ThisWorkbook.Worksheets("Sheet1")
    CheckMappings ws
End Sub

主要

Sub CheckMappings(ByVal ws As Worksheet)
    
    Const SEARCH_FIRST_CELL As String = "A2"
    Const MATCH_FIRST_CELL As String = "B2"
    
    Dim srg As Range: Set srg = RefColumn(ws.Range(SEARCH_FIRST_CELL))
    If srg Is Nothing Then Exit Sub
    Dim mrg As Range: Set mrg = RefColumn(ws.Range(MATCH_FIRST_CELL))
    If mrg Is Nothing Then Exit Sub
    
    Dim sData(): sData = GetColumnRange(srg)
    Dim sDict As Object: Set sDict = DictColumn(sData)
    If sDict Is Nothing Then Exit Sub
    
    Dim mData(): mData = GetColumnRange(mrg)
    Dim mDict As Object: Set mDict = DictColumn(mData)
    If mDict Is Nothing Then Exit Sub
    
    RemoveDictFromDict sDict, mDict
    
    If sDict.Count = 0 Then
        MsgBox "No items to fix.", vbInformation
    Else
        MsgBox "The following " & IIf(sDict.Count = 1, "item is", _
            sDict.Count & " items are") & " not mapped:" & vbLf & vbLf _
            & Join(sDict.Keys, vbLf) & vbLf & vbLf & "Please fix.", vbCritical
    End If
    
End Sub

帮助

引用非空列

Function RefColumn( _
    ByVal FirstCell As Range) _
As Range
    With FirstCell.Cells(1)
        Dim cel As Range: Set cel = .Resize(.Worksheet.Rows.Count - .Row + 1) _
            .Find("*", , xlFormulas, , , xlPrevious)
        If Not cel Is Nothing Then Set RefColumn = .Resize(cel.Row - .Row + 1)
    End With
End Function

列到数组

Function GetColumnRange( _
    ByVal rg As Range, _
    Optional ByVal ColumnIndex As Long = 1) _
As Variant

    With rg.Columns(ColumnIndex)
        If .Rows.Count = 1 Then
            ReDim Data(1 To 1, 1 To 1): Data(1, 1) = .Value
        Else
            Data = .Value
        End If
    End With
    
    GetColumnRange = Data
    
End Function

从数组到字典唯一

Function DictColumn( _
    Data() As Variant, _
    Optional ByVal ColumnIndex As Variant) _
As Object

    Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary")
    dict.CompareMode = vbTextCompare ' case-insensitive
    
    Dim c As Long
    
    If IsMissing(ColumnIndex) Then
        c = LBound(Data, 2) ' use first column index
    Else
        c = CLng(ColumnIndex)
    End If
    
    Dim Key As Variant
    Dim r As Long
    
    For r = LBound(Data, 1) To UBound(Data, 1)
        Key = Data(r, c)
        If Not IsError(Key) Then ' exclude error values
            If Len(CStr(Key)) > 0 Then ' exclude blanks
                dict(Key) = Empty
            End If
        End If
    Next r
   
    If dict.Count = 0 Then Exit Function ' only error values and blanks
    
    Set DictColumn = dict

End Function

删除匹配项

Sub RemoveDictFromDict( _
        ByRef RemoveDict As Object, _
        ByVal MatchDict As Object)
    
    Dim rkey As Variant
    
    For Each rkey In RemoveDict.Keys
        If MatchDict.Exists(rkey) Then RemoveDict.Remove rkey
    Next rkey
    
End Sub

相关问题