今天要讲的示例,之前发微头条已经发过了。算是填坑吧。
问题如下:
解决的思路如下:
思路文字描述:
1:依据原数据采用字典,变成步骤1之后的表格。
2:把步骤1产生的表格,进行拆分,变成步骤2之后的表格
3:经过步骤2之后产生的表格,与原始的表格进行匹配。并赋值给匹配的表格
4:根据赋值好的值,定位表格。给表格进行底色填充,并把重新赋值为空
代码运行结果如下:
原始代码如下:
Sub 字典填充()
Dim dic, arr, brr, crr(), drr, m, err
'后期绑定字典
Set dic = CreateObject("Scripting.Dictionary")
'关闭屏幕刷新
Application.ScreenUpdating = False
'把原始数据及目标数据放入数组
arr = Range("a1").CurrentRegion
brr = Range("e1").CurrentRegion
'清空目标数据的填充
Range("e1").CurrentRegion.Interior.Pattern = xlNone
'把目标数据写入字典,如果key相同,则数据用-相连
For i = 2 To UBound(arr)
If
dic(arr(i, 1)) = arr(i, 2)
Else
dic(arr(i, 1)) = dic(arr(i, 1)) & "-" & arr(i, 2)
End If
Next i
m = 2
'把用-相连的item,放入数据。
ReDim crr(1 To dic.Count, 1 To 1)
crr = WorksheetFunction.Transpose(dic.items)
'把item的数据,分别进行拆分放入drr数组,然后与目标数组进行对比
'如果数据相同,则相应的表格进行赋值为1
For i = 1 To
drr = VBA.Split(crr(i, 1), "-")
For j = 0 To UBound(drr)
For k = 2 To UBound(brr, 2)
If drr(j) = brr(1, k) Then
brr(i + 1, k) = 1
m = m + 1
End If
Next k
Next j
Next i
'数组写入目标区域,判断是否有单元格的值为1
'如果有,则该单元格的底色涂色红色,并给单元格重新赋值为空
Range("e1").CurrentRegion = brr
For i = 2 To UBound(brr)
For j = 2 To UBound(brr, 2)
If Cells(i, j + 4) = 1 Then
Cells(i, j + 4).Interior.Color = 255
Cells(i, j + 4) = ""
End If
Next j
Next i
'开启屏幕刷新
Application.ScreenUpdating = True
'清空字典
Set dic = Nothing
End Sub