今天要讲的示例，之前发微头条已经发过了。算是填坑吧。

问题如下：

解决的思路如下：

思路文字描述：

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 Not

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 dic.Count

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

閱讀更多 浮雲Excel分享 的文章

關鍵字: Excel 表格 步骤