分享彩票分析表格_练习字典查重去重_数组排序VBA代码

吴中泉

如题，今天帮别人写的彩票分析VBA，练习字典查重去重，数组排序，数组变维度，数组作为参数，输入输出数据的VBA代码。


表格的效果


以下是楼主的求助要求：

快乐8是从1到80个号码开出20个号码。
我只选最近7期开奖号码统计。
未开出号码指的是根据最近7期开奖号码统计，1到80有哪些号码没有开出。
连出号如下所示：
例如：149期开出，150期也开出的号码叫连出号。
或者149期、150期、151期开出同样的号码。
或者154期、155期开出同样的号码。等等。
本期重号指的是最近一期开奖号码与上期开奖号码有相同的号码。根据前面表格统计有5个，把这5个号码提出来，放在相应表格里面。
下期斜连号指的是把最近一期号码（2023155期）加减1。
我手填写了一些，还有一些没有填写出来。


我写好代码的附件： 图表快乐8.rar (55.14 KB, 下载次数: 137)

2023-6-16 21:13 上传

点击文件名下载附件

吴中泉

1. Sub ssjss() '2023.6.16 wzq
   
2.     Dim i%, j%, s%, r%, L%, arr, brr
   
3.     Sheet2.Activate
   
4.     r = 8 '[C65536].End(3).Row
   
5.     arr = Range("c1:V" & r).Value
   
6.     Dim d As Object, d1 As Object
   
7.     Set d = CreateObject("scripting.dictionary")
   
8.     Set d1 = CreateObject("scripting.dictionary")
   
9.     L = 20 '定义中奖号任意长度（个数）
   
10.    
    
11.     '求未开出号(用字典)
    
12.     For i = 1 To 80: d(i) = "": Next
    
13.     For i = 2 To r
    
14.         For j = 1 To L
    
15.             If d.exists(Val(arr(i, j))) Then
    
16.                 d.Remove Val(arr(i, j))
    
17.             End If
    
18.         Next
    
19.     Next
    
20.     brr = d.keys
    
21.     Call SelectionSort(brr)
    
22.     Range("c10").Resize(1, d.Count) = brr
    
23.    
    
24.     '求连出号(用字典)
    
25.     d.RemoveAll
    
26.     For i = 3 To r
    
27.         For j = 1 To L
    
28.             d(Val(arr(i - 1, j))) = ""
    
29.         Next
    
30.         For j = 1 To L
    
31.             If d.exists(Val(arr(i, j))) Then
    
32.                 d1(arr(i, j)) = ""
    
33.             End If
    
34.         Next
    
35.         d.RemoveAll
    
36.     Next
    
37.     brr = d1.keys
    
38.     Call SelectionSort(brr)
    
39.     Call array1to2(brr)
    
40.     Range("c11").Resize(UBound(brr) + 1, L) = brr
    
41. 
    
42.     '求本期重号(用字典)
    
43.     d.RemoveAll:    d1.RemoveAll
    
44.     For i = r To r
    
45.         For j = 1 To L
    
46.             d(Val(arr(i - 1, j))) = ""
    
47.         Next
    
48.         For j = 1 To L
    
49.             If d.exists(Val(arr(i, j))) Then
    
50.                 d1(arr(i, j)) = ""
    
51.             End If
    
52.         Next
    
53.         d.RemoveAll
    
54.     Next
    
55.     brr = d1.keys
    
56.     Call SelectionSort(brr)
    
57.     Range("c13").Resize(1, d1.Count) = brr
    
58. 
    
59.     '求下期斜连号(用字典)
    
60.     d.RemoveAll:    d1.RemoveAll
    
61.     For i = r To r
    
62.         For j = 1 To L
    
63.             s = Val(arr(i, j))
    
64.             If s = 1 Then
    
65.                 d(s + 1) = ""
    
66.             ElseIf s = 80 Then
    
67.                 d(s - 1) = ""
    
68.             Else
    
69.                 d(s - 1) = ""
    
70.                 d(s + 1) = ""
    
71.             End If
    
72.         Next
    
73.     Next
    
74.     brr = d.keys
    
75.     Call SelectionSort(brr)
    
76.     Call array1to2(brr)
    
77.     Range("c15").Resize(UBound(brr) + 1, L) = brr
    
78. End Sub
    
79. '选择排序
    
80. Sub SelectionSort(arr)
    
81.     Dim i&, j&, vSwap, min&
    
82.     For i = 0 To UBound(arr) - 1
    
83.         min = i
    
84.         For j = i + 1 To UBound(arr)
    
85.             If arr(min) > arr(j) Then min = j
    
86.         Next
    
87.         If min <> i Then
    
88.             vSwap = arr(min): arr(min) = arr(i): arr(i) = vSwap
    
89.         End If
    
90.     Next
    
91. End Sub
    
92. '数组一维变二维
    
93. Sub array1to2(arr)
    
94.     Dim i%, j%, L%
    
95.     L = UBound(arr) \ 20
    
96.     ReDim brr(0 To L, 0 To 19)
    
97.     For i = 0 To L
    
98.         For j = 0 To 19
    
99.             If i * 20 + j > UBound(arr) Then Exit For
    
100.             brr(i, j) = arr(i * 20 + j)
     
101.         Next
     
102.     Next
     
103.     arr = brr
     
104. End Sub
     
105. 
     
106. 
     

复制代码

·遁去的一·

拜读神作，再来个双色球、大乐透的

吴中泉

·遁去的一· 发表于 2023-6-16 23:58
拜读神作，再来个双色球、大乐透的

再来一个，这叫什么？


图表.zip (113.5 KB, 下载次数: 102)

2023-6-17 09:43 上传

点击文件名下载附件

吴中泉

·遁去的一· 发表于 2023-6-16 23:58
拜读神作，再来个双色球、大乐透的

又来一个，我也不知道叫啥


图表_22.zip (294.89 KB, 下载次数: 97)

2023-6-17 09:50 上传

点击文件名下载附件

吴中泉

再上一个


图表 (1).rar (240.67 KB, 下载次数: 82)

2023-6-17 10:16 上传

点击文件名下载附件

吴中泉

吴中泉 发表于 2023-6-17 10:16
再上一个

1.      'n个数求连号的通用代码(用字典)
   
2.     Dim d As Object
   
3.     Set d = CreateObject("scripting.dictionary")
   
4.     For i = 3 To r
   
5.         m = 0: L = 7 '定义中奖号任意长度（个数）
   
6.         For j = 2 To L
   
7.              m = m + 1
   
8.             If arr(i, j) = arr(i, j - 1) + 1 Then
   
9.                 d(arr(i, j) - m & n) = m + 1
   
10.             Else
    
11.                 m = 0: n = n + 1
    
12.             End If
    
13.         Next
    
14.         For Each n2 In d.items
    
15.             If arr(i, 8) = "" Then
    
16.                 arr(i, 8) = n2
    
17.             Else
    
18.                 arr(i, 8) = arr(i, 8) & " + " & n2
    
19.             End If
    
20.         Next
    
21.         d.RemoveAll: n = 0: n2 = 0
    
22.     Next
    
23.    
    
24.     'n个数求连号的通用代码
    
25.     For i = 3 To r
    
26.         L = 7 '定义中奖号任意长度（个数）
    
27.         ReDim brr(1 To L): ReDim crr(1 To L): m = 0: n = 0
    
28.         For j = 1 To L
    
29.             m = m + 1
    
30.             For k = j + 1 To L
    
31.                 n = n + 1
    
32.                 If crr(k) = 168 Then Exit For
    
33.                 If arr(i, j) + n = arr(i, k) Then
    
34.                     brr(m) = n + 1: crr(k) = 168 '标志不重复访
    
35.                 Else
    
36.                     Exit For
    
37.                 End If
    
38.             Next: n = 0
    
39.         Next
    
40.         For j = 1 To L
    
41.         If brr(j) <> 0 Then
    
42.             If arr(i, 9) <> "" Then
    
43.                 arr(i, 9) = arr(i, 9) & " + " & brr(j)
    
44.             Else
    
45.                 arr(i, 9) = brr(j)
    
46.             End If
    
47.         End If
    
48.         Next
    
49.     Next
    

复制代码

吴中泉

再添


大乐透前区表头用VBA处理.rar (670.43 KB, 下载次数: 79)

2023-6-17 19:14 上传

点击文件名下载附件

hbhs2022

把本期重号表格删除一行

吴中泉

hbhs2022 发表于 2023-6-17 19:37
把本期重号表格删除一行

好的，回头我把修改好的传给你