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
1条答案
按热度按时间omvjsjqw1#
返回不匹配的项目
电子表格
平淡
让
LET变量
VBA语言
板材模块,例如
Sheet1
其余部分进入一个或多个标准模块,例如
Module1
。简单测试
主要
帮助
引用非空列
列到数组
从数组到字典唯一
删除匹配项