如何写这样的代码

吴中泉

hbhs2022 发表于 2023-6-16 08:33
谢谢！晚上9点前睡觉，所以第二天才回复。

搞好了，请测试，有意见请发表。

效果如下图

吴中泉

吴中泉 发表于 2023-6-16 18:31
搞好了，请测试，有意见请发表。

效果如下图

详见附件 图表快乐8.rar (55.93 KB, 下载次数: 2)

2023-6-16 18:32 上传

点击文件名下载附件

hbhs2022

吴中泉 发表于 2023-6-16 18:32
详见附件

谢谢你！完全正确，就是表格太长了，要拖动水平滚动条看。我一般是正常比例看。（100%）
我设置了40个单元格（两行，除了未开出号码是一行，其它是两行），不能往下填写。

吴中泉

hbhs2022 发表于 2023-6-16 19:04
谢谢你！完全正确，就是表格太长了，要拖动水平滚动条看。我一般是正常比例看。（100%）
我设置了40个单 ...

实行两行显示可以，有点麻烦，我来帮你弄一下。
另外，未开出号码有可能占两行哟。
而本期重号只占一行。

hbhs2022

吴中泉 发表于 2023-6-16 19:17
实行两行显示可以，有点麻烦，我来帮你弄一下。
另外，未开出号码有可能占两行哟。
而本期重号只占一行 ...

未开出号码，不可能有20个号码（我统计的是最近7期的号码），因为快乐8开4期为一个周期，理论不会出现这么多。

吴中泉

hbhs2022 发表于 2023-6-16 19:04
谢谢你！完全正确，就是表格太长了，要拖动水平滚动条看。我一般是正常比例看。（100%）
我设置了40个单 ...

又如你所愿，看效果图，觉得好给个“五星好评”吧

吴中泉

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
     

复制代码

吴中泉

吴中泉 发表于 2023-6-16 20:12
又如你所愿，看效果图，觉得好给个“五星好评”吧

详见附件 图表快乐8.rar (55.14 KB, 下载次数: 4)

2023-6-16 20:15 上传

点击文件名下载附件

hbhs2022

吴中泉 发表于 2023-6-16 20:15
详见附件

哪里可以给个“五星好评”？我都不知道。鲜花都不够送，都送完了，还欠别人的鲜花。
谢谢！

吴中泉

hbhs2022 发表于 2023-6-16 20:24
哪里可以给个“五星好评”？我都不知道。鲜花都不够送，都送完了，还欠别人的鲜花。
谢谢！

只有送外卖有五星好评，这里没有。

另外，昨天、今天上午我都帮你编写了程序，你还欠着我的花花呢
怎么感觉像要掌声