求任意三位数上下行【期】 重号个数与重号位置序号的自定义函数

microyip

yylucke 发表于 2019-9-15 12:35
1、如果函数或者说数学模型能破译彩票规律，这个论坛的大神都是财务自由了。
2、你需要那么多自定义函数， ...

你写怎么多，不如先看看这位道长的历史贴

yylucke

microyip 发表于 2019-9-15 17:26
你写怎么多，不如先看看这位道长的历史贴

是哦，道长求助了n多函数，貌似自己就没有写过。
看来道长属于指挥人才。

玉阳山人

。。。。。。。。。。。。

YZC51

yylucke 发表于 2019-9-15 12:35
1、如果函数或者说数学模型能破译彩票规律，这个论坛的大神都是财务自由了。
2、你需要那么多自定义函数， ...

谢谢老师！很有同感！！！

玉阳山人

。。。。。。。。。。。。

lsdongjh

求任意三位数.rar (36.2 KB, 下载次数: 3)

2019-9-16 17:42 上传

点击文件名下载附件

1. Option Explicit
   
2. 
   
3. 
   
4. Function CHONGHAO(rgSource As Range, intType As Integer, Optional intDisplay As Integer = 0, Optional varNum As Variant = "") As Variant
   
5.     Dim arrSource As Variant, arrResult As Variant, arrTemp As Variant, strNum As String
   
6.     Dim lngRows As Long, lngR As Long, strCur As String, strFirst As String
   
7.     Application.Volatile True
   
8.    
   
9.     lngRows = rgSource.Rows.Count
   
10.     strNum = Trim(varNum)
    
11.    
    
12.     If IsArray(rgSource) And lngRows > 1 Then
    
13.         arrSource = rgSource
    
14.     Else
    
15.         MsgBox "输入的数据源有误，请核对后重新输入！"
    
16.         Exit Function
    
17.     End If
    
18.    
    
19.     ReDim arrResult(1 To lngRows, 1 To 3) As String
    
20.    
    
21.     For lngR = 2 To UBound(arrSource)
    
22.         strCur = Trim(arrSource(lngR, 1))
    
23.         strFirst = Trim(arrSource(lngR - 1, 1))
    
24.         If strNum <> "" Then strFirst = strNum
    
25.         If strCur <> "" Then
    
26.             arrTemp = CheckStr(strFirst, strCur, intType)
    
27.             arrResult(lngR, 1) = arrTemp(1)
    
28.             arrResult(lngR, 2) = arrTemp(2)
    
29.             arrResult(lngR, 3) = arrTemp(3)
    
30.         End If
    
31.     Next
    
32.    
    
33.     Select Case intDisplay
    
34.         Case 0
    
35.             arrTemp = Application.WorksheetFunction.Index(arrResult, 0, 3)
    
36.         Case 1
    
37.             arrTemp = Application.WorksheetFunction.Index(arrResult, 0, 1)
    
38.         Case 2
    
39.             arrTemp = Application.WorksheetFunction.Index(arrResult, 0, 2)
    
40.     End Select
    
41.    
    
42.     CHONGHAO = arrTemp
    
43. End Function
    
44. 
    
45. 
    
46. Function CheckStr(strA As String, strB As String, Optional intType As Integer = 1) As Variant
    
47.     Dim lngID As Long, lngSum As Long
    
48.     Dim strCount As Long, strAddRess As String
    
49.     Dim strFind As String, strResult() As String
    
50.    
    
51.     ReDim strResult(1 To 3) As String
    
52.     If intType <> 1 Then intType = 2 '如果不是直选，设置为组选
    
53.    
    
54.     For lngID = 1 To 3
    
55.         Select Case intType
    
56.             Case 1 '直选算法
    
57.                 lngSum = lngSum + Abs((Mid(strA, lngID, 1) = Mid(strB, lngID, 1)) * 1) * (2 ^ (lngID - 1))
    
58.             Case 2 '组选算法
    
59.                 strFind = Mid(strA, lngID, 1)
    
60.                 lngSum = lngSum + Abs((InStr(strB, strFind) > 0) * 1) * (2 ^ (lngID - 1))
    
61.                 strB = Replace(strB, strFind, "-", 1, 1)
    
62.         End Select
    
63.     Next
    
64.    
    
65.     Select Case lngSum
    
66.         Case 0 '无重复
    
67.             strCount = 0: strAddRess = 0
    
68.         Case 1 '百位相同
    
69.             strCount = 1: strAddRess = 1
    
70.         Case 2 '十位相同
    
71.             strCount = 1: strAddRess = 2
    
72.         Case 3 '百位、十位相同
    
73.             strCount = 2: strAddRess = 1
    
74.         Case 4 '个位相同
    
75.             strCount = 1: strAddRess = 3
    
76.         Case 5 '百位、个位相同
    
77.             strCount = 2: strAddRess = 3
    
78.         Case 6 '十位、个位相同
    
79.             strCount = 2: strAddRess = 2
    
80.         Case 7 '三位都相同
    
81.             strCount = 3: strAddRess = 4
    
82.     End Select
    
83.    
    
84.     strResult(1) = strCount
    
85.     strResult(2) = strAddRess
    
86.     strResult(3) = strCount & strAddRess
    
87.    
    
88.     CheckStr = strResult
    
89. End Function
    
90. 
    
91. 
    
92. 
    
93. 
    

复制代码

玉阳山人

。。。。。。。。。。。。

玉阳山人

lsdongjh 发表于 2019-9-16 17:43

老师：经测试，只需再完善以下两处，代码就十全十美了！

1.如截图（1）所示，当A20为空时，B20:G20显示了空白，很正确；A21本来是与A20作比较，由于A20为空，则应该忽略空行，变成A21与A19作比较，计算重号个数和位置序号才对。但《直选模式......》和《组选模式......》B21:D21显示的计算结果不正确。

2.如截图（2）所示，当指定G1为第四参数时，相当于G1为上期号码，而A5:A50作为下期号码；当A5不空时，《直选模式......》和《组选模式......》的E5:G5不应该是空白，也应该如E6:G6那样，显示A5相对于G1的重号个数，位置序号，重号个数&位置序号 才对。


求任意三位数上下行【期】 重号个数与重号位置序号的自定义函数 (2).zip (33.11 KB, 下载次数: 9)

2019-9-17 00:34 上传

点击文件名下载附件

lsdongjh

改一个地方就可以

1.     For lngR = LBound(arrSource) To UBound(arrSource)
   
2.         strCur = Trim(arrSource(lngR, 1))
   
3.         If lngR > LBound(arrSource) Then
   
4.             If Trim(arrSource(lngR - 1, 1)) <> "" Then strFirst = Trim(arrSource(lngR - 1, 1))
   
5.         End If
   
6.         If strNum <> "" Then strFirst = strNum
   
7.         If strCur <> "" And strFirst <> "" Then
   
8.             arrTemp = CheckStr(strFirst, strCur, intType)
   
9.             arrResult(lngR, 1) = arrTemp(1)
   
10.             arrResult(lngR, 2) = arrTemp(2)
    
11.             arrResult(lngR, 3) = arrTemp(3)
    
12.         End If
    
13.     Next

复制代码

玉阳山人

lsdongjh 发表于 2019-9-17 08:38
改一个地方就可以

已测试，完全正确！谢谢老师！！！