[已解决]将excel表中的数组公式用VBA编程实现

protel2003

请高手用VBA编程的方式，将B列数据自动填充到对应的行上，A列重复几次，就填几个行单元格。1、在VBA中使用excel中公式数组的形式编一下；2、用其他VBA编程的方式再搞一个附件是数据表
谢谢

最佳答案

月排行榜 / 总排行榜

eennoo

2022-4-16 15:54

1. Sub 宏2()
   
2. Dim source As Range
   
3. Dim dic As Object, arr, brr
   
4. Set dic = CreateObject("Scripting.Dictionary")
   
5. Set source = Range("a2").CurrentRegion
   
6. Set source = Range("a2").Resize(source.Rows.Count - 1, 2)
   
7. 
   
8. 
   
9. For i = 1 To source.Rows.Count
   
10. With source(i, 1)
    
11. If Not dic.exists(.Text) Then
    
12.     ReDim arr(1 To source.Rows.Count + 1)
    
13.     arr(1) = 1
    
14.     arr(2) = .Offset(0, 1).Text
    
15.     dic.Add .Text, arr
    
16.    
    
17. Else
    
18.     brr = dic(.Text)
    
19.     brr(1) = brr(1) + 1
    
20.     brr(brr(1) + 1) = .Offset(0, 1).Text
    
21.     dic(.Text) = brr
    
22. End If
    
23. End With
    
24. Next
    
25. 
    
26. ReDim arr(1 To source.Rows.Count, 1 To source.Rows.Count)
    
27. For i = 1 To source.Rows.Count
    
28. t = dic(source(i, 1).Text)
    
29. For j = 1 To t(1)
    
30. arr(i, j) = t(1 + j)
    
31. Next
    
32. Next
    
33. [C2].Resize(source.Rows.Count, source.Rows.Count) = arr
    
34. End Sub
    

复制代码

跳转到最佳答案楼层

eennoo

1. Sub 宏2()
   
2. Dim source As Range
   
3. Dim dic As Object, arr, brr
   
4. Set dic = CreateObject("Scripting.Dictionary")
   
5. Set source = Range("a2").CurrentRegion
   
6. Set source = Range("a2").Resize(source.Rows.Count - 1, 2)
   
7. 
   
8. 
   
9. For i = 1 To source.Rows.Count
   
10. With source(i, 1)
    
11. If Not dic.exists(.Text) Then
    
12.     ReDim arr(1 To source.Rows.Count + 1)
    
13.     arr(1) = 1
    
14.     arr(2) = .Offset(0, 1).Text
    
15.     dic.Add .Text, arr
    
16.    
    
17. Else
    
18.     brr = dic(.Text)
    
19.     brr(1) = brr(1) + 1
    
20.     brr(brr(1) + 1) = .Offset(0, 1).Text
    
21.     dic(.Text) = brr
    
22. End If
    
23. End With
    
24. Next
    
25. 
    
26. ReDim arr(1 To source.Rows.Count, 1 To source.Rows.Count)
    
27. For i = 1 To source.Rows.Count
    
28. t = dic(source(i, 1).Text)
    
29. For j = 1 To t(1)
    
30. arr(i, j) = t(1 + j)
    
31. Next
    
32. Next
    
33. [C2].Resize(source.Rows.Count, source.Rows.Count) = arr
    
34. End Sub
    

复制代码

protel2003

数据表截图

protel2003

eennoo 发表于 2022-4-16 15:54

谢谢，非常感谢