通过一个表格转换案例练习数组的各种用法\欢迎交流讨论

吴中泉

编写了四种过程,来将图中的表格进行转换,主要练习数组使用和结合字典使用,也是网上一个网友需求的.

代码在附件中
练习数组的各种用法.zip (21.46 KB, 下载次数: 12)

2023-4-18 10:37 上传

点击文件名下载附件

jiangxiaoyun

用字典记录行号列号，然后将数据贴上去就是了。纯数组有序无序写法不一样

fanyoulin

如果不排序的话，一个字典就搞定了。

如果需要排序，可以直接利用单元格排序再多写两行代码。

吴中泉

fanyoulin 发表于 2023-4-18 13:47
如果不排序的话，一个字典就搞定了。

如果需要排序，可以直接利用单元格排序再多写两行代码。

发此贴的目的是练习数组使用.A列的数据都是有序的,并且相同的数据都连续排列.
你发的代码很好,我得慢慢学习消化

吴中泉

下面无事，根据网友的代码，我又编制了两段代码，主要是对无序的项目进行数据汇总和表格转换，并作了速度对比。

代码如下：

1. 
   
2. Sub 用字典表格转换() '8千行无序10.56秒,'有序5.59秒
   
3. '字典'可对无序的项目进行汇总
   
4. Dim arr, brr, i, d
   
5. Set d = CreateObject("Scripting.Dictionary")
   
6. Range("D2").CurrentRegion.ClearContents
   
7. T = Timer
   
8. arr = Range("A1").CurrentRegion
   
9. For i = 2 To UBound(arr)
   
10.     d(arr(i, 1)) = d(arr(i, 1)) & "|B" & i '装单元格的文本地址
    
11. Next
    
12. For i = 0 To d.Count - 1
    
13.     brr = d.items
    
14.     brr = Split(brr(i), "|")
    
15.     For j = 1 To UBound(brr)
    
16.         Cells(i + 2, j + 4) = Range(brr(j))
    
17.     Next
    
18. Next
    
19. Range("d" & 2).Resize(d.Count, 1) = _
    
20.     WorksheetFunction.Transpose(d.keys)
    
21. Set d = Nothing
    
22. MsgBox Timer - T
    
23. End Sub
    
24. 
    
25. 
    
26. Sub 坛友编的() '8千行无序10.86秒,'有序4.9秒
    
27. Dim arr, brr, i, d
    
28. Set d = CreateObject("Scripting.Dictionary")
    
29. 'Sheet2.Activate
    
30. Range("D2").CurrentRegion.ClearContents
    
31. T = Timer
    
32. js = 0
    
33. For i = 1 To [A65500].End(3).Row
    
34.     x = Cells(i, 1)
    
35.     If d.exists(x) Then
    
36.         Cells(d(x), Cells(d(x), 2000).End(1).Column + 1) = Cells(i, 2)
    
37.     Else
    
38.         d(x) = js + 1
    
39.         js = js + 1
    
40.         Cells(d(x), 4) = Cells(i, 1)
    
41.         Cells(d(x), 5) = Cells(i, 2)
    
42.     End If
    
43. Next
    
44. MsgBox Timer - T
    
45. Set d = Nothing
    
46. End Sub

复制代码

吴中泉

吴中泉 发表于 2023-4-20 15:52
下面无事，根据网友的代码，我又编制了两段代码，主要是对无序的项目进行数据汇总和表格转换，并作了速度对 ...

我发的最后一个过程代码为什么没有了，再发一次吧。
8千行无序的数据处理用时0.039秒,'有序0.04秒,比上面两个过程快了200多倍

1. Sub 我改编的() '8千行无序0.039秒,'有序0.04秒,比上面快了200多倍
   
2. Dim arr, brr(), i, c, r, d, x
   
3. Set d = CreateObject("Scripting.Dictionary")
   
4. Range("D2").CurrentRegion.ClearContents
   
5. T = Timer: s = Columns.Count
   
6. er = [A65500].End(3).Row
   
7. arr = Range("A1:B" & er)
   
8. For i = 1 To UBound(arr)
   
9.     x = arr(i, 1)
   
10.     d(x) = d(x) + 1 '列计数
    
11.     If d(x) > Mc Then Mc = d(x) '找最大的列号
    
12. Next
    
13. ReDim brr(1 To d.Count, 1 To Mc + 2)
    
14. d.RemoveAll
    
15. For i = 1 To UBound(arr)
    
16.     x = arr(i, 1)
    
17.     If d.exists(x) Then
    
18.         c = d(x)(1) + 1 '列计数
    
19.         r = d(x)(0) '用字典记录单元格的新位置
    
20.         d(x) = Array(r, c) '行列号
    
21.         brr(r, c) = arr(i, 2)
    
22.     Else
    
23.         c = 2
    
24.         js = js + 1 '行计数
    
25.         d(x) = Array(js, c)
    
26.         brr(js, 1) = arr(i, 1)
    
27.         brr(js, 2) = arr(i, 2)
    
28.     End If
    
29. Next
    
30. Range("D1").Resize(js, Mc + 2) = brr
    
31. MsgBox Timer - T
    
32. Set d = Nothing
    
33. End Sub
    

复制代码