[已解决]数字出现次数的统计 的 问题 vba 求解

1testvba

附件： 20120329help.rar (6.61 KB, 下载次数: 18)

2012-3-30 00:43 上传

点击文件名下载附件

想实现这样的 次数统计并排序功能

1.读取根目录下的test.txt文本的内容
如
20120329093 81585
20120329094 89948
20120329095 16382
20120329096 11050
20120329097 27818
20120329098 51022

2.
B1=345
对 每行的 空格的右边的数字进行 出现次数的多少来排序、
那么这里的345的意思是。取 每行 空格的右边的数字串的 第3第4第5位 来做数字出现的统计

3.
做三次统计。
第一次：
取
20120329093 81585
20120329095 16382
20120329097 27818

第二次：
取
20120329094 89948
20120329096 11050
20120329098 51022

即 分别对 test.txt的文本内容的 奇数行和偶数行的 第3第4第5位 出现的数字做统计

第3次：
总统计。即对test.txt的文本内容的 第3第4第5位 出现的数字做统计。

最后得到结果

奇数行
8[4] 5[2] 3[1] 2[1] 1[1] 9[0] 7[0] 6[0] 4[0] 0[0]
偶数行
0[3] 2[2] 9[1] 8[1] 5[1] 4[1] 7[0] 6[0] 3[0] 1[0]  
总排序
8[5] 5[3] 2[3] 0[3] 9[1] 4[1] 3[1] 1[1] 7[0] 6[0]

请老师们帮忙，谢谢

最佳答案

月排行榜 / 总排行榜

liuguansky

2012-3-31 14:41

1testvba 发表于 2012-3-31 12:01
liuguansky 老师好。、。

出现次数为0的。就是 0-9 10个数 未出现的 数字。

1. Sub justtest()
   
2.     Dim S$, Pa$, Sd$, Ar(1 To 3), j As Byte, ArS(1 To 6, 1 To 1)
   
3.     Dim d(1 To 3) As New Dictionary, K&, M$, A
   
4.     For j = 1 To 3
   
5.         Ar(j) = Mid([b1], j, 1)
   
6.     Next j
   
7.     Pa = ThisWorkbook.Path & "\test.txt"
   
8.     Open Pa For Input As #1
   
9.         K = 0
   
10.         Do Until EOF(1)
    
11.             Line Input #1, Sd
    
12.             K = K + 1
    
13.             Sd = Split(Sd)(1)
    
14.             For j = 1 To 3
    
15.                 M = Mid(Sd, Ar(j), 1)
    
16.                 d(3)(M) = d(3)(M) + 1
    
17.                 If K Mod 2 = 1 Then
    
18.                     d(1)(M) = d(1)(M) + 1
    
19.                 Else
    
20.                     d(2)(M) = d(2)(M) + 1
    
21.                 End If
    
22.             Next j
    
23.         Loop
    
24.     Close #1
    
25.     ArS(1, 1) = "奇数行": ArS(3, 1) = "偶数行": ArS(5, 1) = "总排序"
    
26.     ArS(2, 1) = SA(d(1)): ArS(4, 1) = SA(d(2)): ArS(6, 1) = SA(d(3))
    
27.     [a1:a6] = ArS
    
28.     Erase d
    
29.     MsgBox "处理完毕！"
    
30. End Sub
    
31. Function SA(d As Dictionary) As String
    
32.     Dim A1, A2, i&, j&, C
    
33.     For i = 0 To 9
    
34.         If Not d.Exists(i & "") Then
    
35.             d.Add i & "", 0
    
36.         End If
    
37.     Next i
    
38.     A1 = d.Keys: A2 = d.Items
    
39.     For i = 0 To UBound(A1) - 1
    
40.         For j = i + 1 To UBound(A1)
    
41.             If A2(i) < A2(j) Then
    
42.                 C = A1(i): A1(i) = A1(j): A1(j) = C
    
43.                 C = A2(i): A2(i) = A2(j): A2(j) = C
    
44.             End If
    
45.     Next j, i
    
46.     For i = 0 To UBound(A1)
    
47.         SA = SA & " " & A1(i) & "[" & A2(i) & "]"
    
48.     Next i
    
49.     SA = Mid(SA, 2)
    
50. End Function
    

复制代码

跳转到最佳答案楼层

雄鹰

为什么不上传附件呢？

1testvba

老师好

附件 不是在 最前面 吗？

1testvba

{:031:}

继续等待解答、

1testvba

很有喜感

{:271:}

1testvba

谢谢 浏览过的  老师们

liuguansky

那些次数为0的是返回的什么样的数据？
这里的结果没有返回

1. 
   
2. Sub justtest()
   
3.     Dim S$, Pa$, Sd$, Ar(1 To 3), j As Byte, ArS(1 To 6, 1 To 1)
   
4.     Dim d(1 To 3) As New Dictionary, K&, M$, A
   
5.     For j = 1 To 3
   
6.         Ar(j) = Mid([b1], j, 1)
   
7.     Next j
   
8.     Pa = ThisWorkbook.Path & "\test.txt"
   
9.     Open Pa For Input As #1
   
10.         K = 0
    
11.         Do Until EOF(1)
    
12.             Line Input #1, Sd
    
13.             K = K + 1
    
14.             Sd = Split(Sd)(1)
    
15.             For j = 1 To 3
    
16.                 M = Mid(Sd, Ar(j), 1)
    
17.                 d(3)(M) = d(3)(M) + 1
    
18.                 If K Mod 2 = 1 Then
    
19.                     d(1)(M) = d(1)(M) + 1
    
20.                 Else
    
21.                     d(2)(M) = d(2)(M) + 1
    
22.                 End If
    
23.             Next j
    
24.         Loop
    
25.     Close #1
    
26.     ArS(1, 1) = "奇数行": ArS(3, 1) = "偶数行": ArS(5, 1) = "总排序"
    
27.     ArS(2, 1) = SA(d(1)): ArS(4, 1) = SA(d(2)): ArS(6, 1) = SA(d(3))
    
28.     [a1:a6] = ArS
    
29.     Erase d
    
30.     MsgBox "处理完毕！"
    
31. End Sub
    
32. Function SA(d As Dictionary) As String
    
33.     Dim A1, A2, i&, j&, C
    
34.     A1 = d.Keys: A2 = d.Items
    
35.     For i = 0 To UBound(A1) - 1
    
36.         For j = i + 1 To UBound(A1)
    
37.             If A2(i) < A2(j) Then
    
38.                 C = A1(i): A1(i) = A1(j): A1(j) = C
    
39.                 C = A2(i): A2(i) = A2(j): A2(j) = C
    
40.             End If
    
41.     Next j, i
    
42.     For i = 0 To UBound(A1)
    
43.         SA = SA & " " & A1(i) & "[" & A2(i) & "]"
    
44.     Next i
    
45.     SA = Mid(SA, 2)
    
46. End Function
    

复制代码

新建文件夹.rar (12.19 KB, 下载次数: 24)

2012-3-31 08:52 上传

点击文件名下载附件

1testvba

liuguansky 老师好。、。

出现次数为0的。就是 0-9 10个数 未出现的 数字。

不显示次数0 也没关系。再后面自动加上 次数为0，即未出现的数字 也可以、

比如这样：

奇数行
8[4] 5[2] 3[1] 2[1] 1[1] 04679
偶数行
0[3] 2[2] 9[1] 8[1] 5[1] 4[1] 1367
总排序
8[5] 5[3] 2[3] 0[3] 9[1] 4[1] 3[1] 1[1] 67

liuguansky

1testvba 发表于 2012-3-31 12:01
liuguansky 老师好。、。

出现次数为0的。就是 0-9 10个数 未出现的 数字。

1. Sub justtest()
   
2.     Dim S$, Pa$, Sd$, Ar(1 To 3), j As Byte, ArS(1 To 6, 1 To 1)
   
3.     Dim d(1 To 3) As New Dictionary, K&, M$, A
   
4.     For j = 1 To 3
   
5.         Ar(j) = Mid([b1], j, 1)
   
6.     Next j
   
7.     Pa = ThisWorkbook.Path & "\test.txt"
   
8.     Open Pa For Input As #1
   
9.         K = 0
   
10.         Do Until EOF(1)
    
11.             Line Input #1, Sd
    
12.             K = K + 1
    
13.             Sd = Split(Sd)(1)
    
14.             For j = 1 To 3
    
15.                 M = Mid(Sd, Ar(j), 1)
    
16.                 d(3)(M) = d(3)(M) + 1
    
17.                 If K Mod 2 = 1 Then
    
18.                     d(1)(M) = d(1)(M) + 1
    
19.                 Else
    
20.                     d(2)(M) = d(2)(M) + 1
    
21.                 End If
    
22.             Next j
    
23.         Loop
    
24.     Close #1
    
25.     ArS(1, 1) = "奇数行": ArS(3, 1) = "偶数行": ArS(5, 1) = "总排序"
    
26.     ArS(2, 1) = SA(d(1)): ArS(4, 1) = SA(d(2)): ArS(6, 1) = SA(d(3))
    
27.     [a1:a6] = ArS
    
28.     Erase d
    
29.     MsgBox "处理完毕！"
    
30. End Sub
    
31. Function SA(d As Dictionary) As String
    
32.     Dim A1, A2, i&, j&, C
    
33.     For i = 0 To 9
    
34.         If Not d.Exists(i & "") Then
    
35.             d.Add i & "", 0
    
36.         End If
    
37.     Next i
    
38.     A1 = d.Keys: A2 = d.Items
    
39.     For i = 0 To UBound(A1) - 1
    
40.         For j = i + 1 To UBound(A1)
    
41.             If A2(i) < A2(j) Then
    
42.                 C = A1(i): A1(i) = A1(j): A1(j) = C
    
43.                 C = A2(i): A2(i) = A2(j): A2(j) = C
    
44.             End If
    
45.     Next j, i
    
46.     For i = 0 To UBound(A1)
    
47.         SA = SA & " " & A1(i) & "[" & A2(i) & "]"
    
48.     Next i
    
49.     SA = Mid(SA, 2)
    
50. End Function
    

复制代码