VBA——字典对象的常规用法和嵌套用法示例
Rem 本视频完整代码
'方法一
Sub 字典匹配数据()
Dim arr
Dim i As Long
Dim dict As Object
Dim key As String
arr = Sheets("长摊索引表").UsedRange.Value
Set dict = CreateObject("Scripting.Dictionary")
For i = LBound(arr, 1) + 1 To UBound(arr, 1)
key = CStr(arr(i, 1))
If Not dict.Exists(key) Then
dict(key) = arr(i, 3)
Else
dict(key) = dict(key) & "_" & arr(i, 3)
End If
Next i
Dim brr
Dim j As Long
Dim key1
Dim 新行 As Long
brr = Sheets("辅材表").UsedRange.Value
新行 = 2
For j = LBound(brr, 1) + 1 To UBound(brr, 1)
key1 = CStr(brr(j, 1))
If dict.Exists(key1) Then
If InStr(dict(key1), brr(j, 3)) > 0 Then
'数据满足条件，需要存到【长摊表】中
With Sheets("长摊表")
.Cells(新行, 1).Value = "'" & brr(j, 1)
.Cells(新行, 2).Value = "'" & brr(j, 2)
.Cells(新行, 3).Value = "'" & brr(j, 3)
End With
新行 = 新行 + 1
End If
End If
Next j
End Sub
'方法二
Sub 字典匹配数据_匹配3列_拼接key()
Dim arr
Dim i As Long
Dim dict As Object
Dim key As String
arr = Sheets("长摊索引表").UsedRange.Value
Set dict = CreateObject("Scripting.Dictionary")
For i = LBound(arr, 1) + 1 To UBound(arr, 1)
key = CStr(arr(i, 1)) & "_" & CStr(arr(i, 2)) & "_" & CStr(arr(i, 3))
If Not dict.Exists(key) Then
dict(key) = True
End If
Next i
Dim brr
Dim j As Long
Dim key1
Dim 新行 As Long
brr = Sheets("辅材表").UsedRange.Value
新行 = 2
Sheets("长摊表").UsedRange.Rows.Delete
For j = LBound(brr, 1) + 1 To UBound(brr, 1)
key1 = CStr(brr(j, 1)) & "_" & CStr(brr(j, 2)) & "_" & CStr(brr(j, 3))
If dict.Exists(key1) Then
'数据满足条件，需要存到【长摊表】中
With Sheets("长摊表")
.Cells(新行, 1).Value = "'" & brr(j, 1)
.Cells(新行, 2).Value = "'" & brr(j, 2)
.Cells(新行, 3).Value = "'" & brr(j, 3)
End With
新行 = 新行 + 1
End If
Next j
End Sub
'方法三
Sub 字典匹配数据_字典嵌套()
Dim arr
Dim i As Long
Dim dict As Object
Dim dict1 As Object
Dim key As String
Dim key1 As String
arr = Sheets("长摊索引表").UsedRange.Value
Set dict = CreateObject("Scripting.Dictionary")
For i = LBound(arr, 1) + 1 To UBound(arr, 1)
key = CStr(arr(i, 1))
If Not dict.Exists(key) Then
Set dict(key) = CreateObject("Scripting.Dictionary")
End If
'Set dict1 = dict(key)
key1 = CStr(arr(i, 2))
If Not dict(key).Exists(key1) Then
dict(key)(key1) = CStr(arr(i, 3))
End If
Next i
Dim brr
Dim j As Long
Dim key2 As String
Dim key3 As String
Dim 新行 As Long
brr = Sheets("辅材表").UsedRange.Value
新行 = 2
Sheets("长摊表").UsedRange.Rows.Delete
For j = LBound(brr, 1) + 1 To UBound(brr, 1)
key2 = CStr(brr(j, 1))
If dict.Exists(key2) Then
key3 = CStr(brr(j, 2))
If dict(key2).Exists(key3) Then
If dict(key2)(key3) = CStr(brr(j, 3)) Then
'数据满足条件，需要存到【长摊表】中
With Sheets("长摊表")
.Cells(新行, 1).Value = "'" & brr(j, 1)
.Cells(新行, 2).Value = "'" & brr(j, 2)
.Cells(新行, 3).Value = "'" & brr(j, 3)
End With
新行 = 新行 + 1
End If
End If
End If
Next j
End Sub
