自动分类汇总功能开发

opiona

内建了：条件格式

chaohuahch

1. 
   
2. 
   
3. Sub 字典填充()
   
4. Dim dic, arr, brr, crr(), drr, m, err
   
5. Set dic = CreateObject("Scripting.Dictionary")
   
6. Application.ScreenUpdating = False
   
7. arr = Range("a1").CurrentRegion
   
8. brr = Range("e1").CurrentRegion
   
9. Range("e1").CurrentRegion.Interior.Pattern = xlNone
   
10. 
    
11. For i = 2 To UBound(arr)
    
12.     If Not dic.exists(arr(i, 1)) Then
    
13.       dic(arr(i, 1)) = arr(i, 2)
    
14.     Else
    
15.       dic(arr(i, 1)) = dic(arr(i, 1)) & "-" & arr(i, 2)
    
16.     End If
    
17. Next i
    
18. m = 2
    
19. 
    
20. ReDim crr(1 To dic.Count, 1 To 1)
    
21. crr = WorksheetFunction.Transpose(dic.items)
    
22. 
    
23. For i = 1 To dic.Count
    
24. drr = VBA.Split(crr(i, 1), "-")
    
25.   For j = 0 To UBound(drr)
    
26.     For k = 2 To UBound(brr, 2)
    
27.        If drr(j) = brr(1, k) Then
    
28.           brr(i + 1, k) = 1
    
29.           m = m + 1
    
30.        End If
    
31.     Next k
    
32.   Next j
    
33. Next i
    
34. 
    
35. Range("e1").CurrentRegion = brr
    
36. For i = 2 To UBound(brr)
    
37.    For j = 2 To UBound(brr, 2)
    
38.       If Cells(i, j + 4) = 1 Then
    
39.          Cells(i, j + 4).Interior.Color = 255
    
40.         Cells(i, j + 4) = ""
    
41.       End If
    
42.     Next j
    
43.   Next i
    
44. Application.ScreenUpdating = True
    
45. Set dic = Nothing
    
46. End Sub
    

复制代码

bpw0258

学习了，谢谢各位前辈指点！