麻辣家族討論版版 - Powered by Discuz! Board

Sub 按鈕形2_Click() '7*6
Application.ScreenUpdating = False '螢幕
rrr = Range("BG7")
If rrr = "" Then MsgBox "尚未輸入起始列數!": Exit Sub
'取出連續透支數
losetime = Sheets("7x6").[c7]
If losetime < 0 Then MsgBox "透支不可為負數!": Call after: Exit Sub
t1 = Hour(Now()) * 3600 + Minute(Now()) * 60 + Second(Now())
Dim ar, TestArray() As String, br(), x&, y&, z&, n&, rng2, win_num, aa()
win_num = 0 '最後成功紀錄的組數
'清除BA欄資料
Sheets("7x6").Columns("Bt:Bt").ClearContents
Sheets("data").Columns("af:bu").ClearContents
'檢查data分頁有幾筆資料
num1 = WorksheetFunction.CountA(Sheets("data").Range("K:K")) / 7
If num1 < 2 Then MsgBox "資料不足夠!": Exit Sub
'建立data分頁的陣列
Rng = Sheets("data").[w1].Resize(num1 * 8, 1)
'取出盈虧陣列
earn = Sheets("7x6").Range("bg" & rrr).Resize(ED("bg", , "7x6") - rrr + 1, 1).Value
'將基本排序輸入陣列
ReDim ar(1 To num1, 1 To 1)
For i = 1 To num1
ar(i, 1) = Rng((i - 1) * 8 + 1, 1)
Next
Dim D As Object
Set D = CreateObject("SCRIPTING.DICTIONARY") '字典物件
'跑出排列組合---------------------------------------------------
For y = x + 1 To UBound(ar) - 1
For z = y + 1 To UBound(ar)
'檢查六個元素內容是否有重複
reallyname = ar(y, 1) & "_" & ar(z, 1)
temp = Split(reallyname, "_")
For i = 0 To 5
If Not D.Exists(CStr(temp(i))) Then
D.Add CStr(temp(i)), i
Else
D.RemoveAll: GoTo fn2
End If
Next
D.RemoveAll
n = n + 1
ReDim Preserve br(1 To 2, 1 To n)
br(1, n) = ar(y, 1)
br(2, n) = ar(z, 1)
fn2: Next
Next
Set D = Nothing
Set ar = Nothing
If n = 0 Then MsgBox "經過移除重複的組合之後,沒有任何一組可以合成7*7*6": Exit Sub
br = Application.Transpose(br)
ReDim rng2(1 To 7, 1 To 42)
'將組合後的內容輸入至陣列內---------------------------------------------------
'跑每一筆未來的排列組合
Rng = Sheets("data").[w1].Resize(num1 * 8, 1)
For i = 1 To UBound(br)
'跑2個組合
For j = 1 To 2
'跑每一筆原本的組合
For K = 1 To UBound(Rng) Step 8
'判斷原本組合的代碼,是否符合排列組合之後的代碼
If CStr(Rng(K, 1)) = CStr(br(i, j)) Then
'建立原本的陣列
org_rng = Sheets("data").Range("J" & K + 1).Resize(7, 21)
'找到代碼之後,將原本的陣列內容輸入至新的排列組合陣列內
For L = 1 To 7
For M = 1 To 21
'L是1~7的列數,M是欄數,K是該編號的列數位置
rng2(L, M + (j - 1) * 21) = CStr(org_rng(L, M))
Next
Next
Exit For
End If
Next
Next
'每跑完一個完整的7*21組合,就把資料放到7*3分頁裡面進行比對-----------------------------
'放置資料
Sheets("7x6").[I9].Resize(7, 42).Value = rng2
'跑每一筆盈虧
x = 0 '用來計算連續幾筆透支
For j = 1 To UBound(earn)
If earn(j, 1) = "" Then GoTo fn
If earn(j, 1) >= 0 Then: x = 0: GoTo fn
x = x + 1
If x = losetime Then GoTo f1 '到達透支標準=>不予紀錄,執行下一個組合
fn: Next
'可以執行到這邊,代表透支數量沒有超過,需要紀錄編號組合到[ba]位置
win_num = win_num + 1 '成功的次數
Sheets("7x6").Range("Bt" & win_num).Value = win_num & "--" & br(i, 1) & "_" & br(i, 2)
Sheets("data").Range("as" & (win_num - 1) * 8 + 1).Value = br(i, 1) & "_" & br(i, 2)
Sheets("data").Range("af" & (win_num - 1) * 8 + 1).Value = win_num
Sheets("data").Range("af" & (win_num - 1) * 8 + 2).Resize(7, 42).Value = rng2
f1: Next
T2 = Hour(Now()) * 3600 + Minute(Now()) * 60 + Second(Now())
MsgBox win_num & "/" & UBound(br) & "(組)共耗時 " & T2 - t1 & " 秒"
End Sub

複製代碼