標題: [發問] 搜尋前3大&前3小值。 [打印本頁]

---

作者: ziv976688    時間: 2021-9-5 18:15     標題: 搜尋前3大&前3小值。

本帖最後由 ziv976688 於 2021-9-5 18:27 編輯

[attach]33981[/attach]
備註：
前3大和前3小的名次以中式排名(即同名次可以多個)為基準。
本範例共有5個子資料夾(1883~1879)。
編寫流程請解題者擇宜訂定。

將TEST資料夾內的各n個子資料夾依由大而小順序打開後，
再增需求如下：
1_將有"統"關鍵字的檔案名稱之第4段"數字由大而小"，從Sheets("Sheet1").[A33]起始，每跳17列依序往下填入。

2_以上述打開後的檔案：
搜尋D欄和E欄之單欄的前3大的數值和前3小的數值，並以同列的B欄值，對應Sheets("Sheet1").[C1:AY1]的同值，
然後在Sheets("Sheet1")A欄相同期數右邊總次數和倍數之前3大和前3小的對應儲存格填上"V"~
EX：開啟7統_0_1884期_1883_49個_1次的檔案~
D欄最大值=D31=396；同列B31=30；則在Sheets("Sheet1").[AF34]填入"V"
D欄次大值=D42=378；同列B42=41；則在Sheets("Sheet1").[AQ35]填入"V"
D欄三大值=D34=372；同列B34=33；則在Sheets("Sheet1").[AI36]填入"V"
D欄最小值=D22=156；同列B22=21；則在Sheets("Sheet1").[W38]填入"V"
D欄次小值=D41=192；同列B41=40；則在Sheets("Sheet1").[AP39]填入"V"
D欄三小值=D43=198；同列B43=42；則在Sheets("Sheet1").[AR40]填入"V"

搜尋E欄的之前3大的數值和前3小的數值，並以同列的B欄值，對應Sheets("Sheet1").[C1:AY1]的同值，
然後在Sheets("Sheet1")A欄相同期數右邊倍數的前3大和前3小之對應儲存格填上"V"~
E欄最大值=E31=8.082；同列B31=30；則在Sheets("Sheet1").[AF42]填入"V"
E欄次大值=E42=7.714；同列B42=41；則在Sheets("Sheet1").[AQ43]填入"V"
E欄三大值=E34=7.592；同列B34=33；則在Sheets("Sheet1").[AI44]填入"V"
E欄最小值=E22=3.250；同列B22=21；則在Sheets("Sheet1").[W46]填入"V"
E欄次小值=E43=4.041；同列B43=42；則在Sheets("Sheet1").[AR47]填入"V"
E欄三小值=E41=4.085；同列B41=40；則在Sheets("Sheet1").[AP48]填入"V"

其餘1882~1879類推：詳如範例。

以上需求語法~懇請各位大大指導和幫忙！ 謝謝！

---

作者: samwang    時間: 2021-9-6 12:15

回復 1# ziv976688


搜尋D欄和E欄之單欄的前3大的數值和前3小的數值，並以同列的B欄值，對應Sheets("Sheet1").[C1:AY1]的同值，
>> 新增紅字如下，請試看看，謝謝   

Private Sub CommandButton1_Click()
Dim Path As String, A, Ar(1 To 1000, 1 To 2), Ar1(), Arr, Brr(1 To 7), Crr, xD, T%, i&, j&
Dim Ar2(), Drr(1 To 16, 1 To 49), R%, K%
...
...
For i = 1 To n            '開啟Ar，找檔名有"統"裝入Ar1
    Set f = fs.GetFolder(Ar(i, 1))
    Set fc = f.Files
    For Each f1 In fc
        If InStr(f1.Path, "統") Then
            ReDim Preserve Ar1(n1)
            Ar1(n1) = f1.Path
            n1 = n1 + 1
        End If
    Next f1
Next i

fileOrg = ActiveWorkbook.Name
If n1 > 0 Then
    R = 33
    表頭 = Array("總次數", "最大", "次大", "三大", "", "最小", "次小", "三小", _
                  "倍數", "最大", "次大", "三大", "", "最小", "次小", "三小")
    For i1 = 0 To n - 1   '開啟Ar1
        Set WB = Workbooks.Open(Ar1(i1))
        fn = Split(Ar1(i1), "_")(5)
        With Sheets(1)
            If .FilterMode Then .ShowAllData
            With .Range(.[B1], .[E65536].End(3))
                Crr = .Value
                .Sort Key1:=.Item(3), Order1:=2, Header:=1
                Arr = .Value
                .Value = Crr
            End With
        End With
        WB.Close
        For i = 2 To 4  '前3數值
            ReDim Preserve Ar2(K): Ar2(K) = Arr(i, 1): K = K + 1
        Next
        For i = UBound(Arr) To 48 Step -1 '最後3數值
            ReDim Preserve Ar2(K): Ar2(K) = Arr(i, 1): K = K + 1
        Next
        For i = 0 To UBound(Ar2)
            T = Ar2(i)
            If i < 3 Then
                Drr(i + 1, T) = "V": Drr(i + 9, T) = "V"
            Else
                Drr(i + 2, T) = "V": Drr(i + 10, T) = "V"
            End If
        Next
        With Sheets("Sheet1")
            .Range("a" & R) = fn
            .Range("b" & R).Resize(16) = Application.Transpose(表頭)
            .Range("c" & R + 1).Resize(15, 49) = Drr
            R = .[b65536].End(3).Row + 1
        End With
        Erase Ar2: Erase Drr: K = 0
    Next
End If
Set fs = Nothing: Set f = Nothing: Set fc = Nothing
...
...

---

作者: ziv976688    時間: 2021-9-6 14:14

本帖最後由 ziv976688 於 2021-9-6 14:27 編輯

回復 2# samwang
謝謝您的再次指導。
測試結果 :
１＿少了1列間隔空白列~
EX；
Ａ４９＝１８８２，Ｂ４９：Ｂ６４＝表頭
正確為：
Ａ５０＝１８８２，Ｂ５０：Ｂ６５＝表頭

Ａ６５＝１８８１，Ｂ６５：Ｂ８０＝表頭
正確為：
Ａ６７＝１８８１，Ｂ６７：Ｂ８２＝表頭

Ａ８１＝１８８０，Ｂ８１：Ｂ９６＝表頭
正確為：
Ａ８４＝１８８０，Ｂ８４：Ｂ９９＝表頭

其餘．．．類推

２＿Ｖ的總數量目前是５８個（正確是６０個）∼5期*2欄*(前3大+前3小)>=60~
但這個等上項列數調整後，小弟再測試結果∼如真有誤時，再勞煩您修正。
謝謝您
[attach]33984[/attach]

---

作者: samwang    時間: 2021-9-6 15:20

回復 3# ziv976688


１＿少了1列間隔空白列~
>> 更改如下紅字，謝謝

With Sheets("Sheet1")
            .Range("a" & R) = fn
            .Range("b" & R).Resize(16) = Application.Transpose(表頭)
            .Range("c" & R + 1).Resize(15, 49) = Drr
            R = .[b65536].End(3).Row + 2
End With

---

作者: ziv976688    時間: 2021-9-6 18:33

回復 4# samwang
謝謝您的賜正。
打"V"的部分~我的效果檔範例也有筆漏~請在AP91填入"V"。謝謝!

打"V"部分的測試結果 :
1882；1881；1879~OK

1883~請修正下列儲存格~
AP47=""；AR47=V
AP48=V；AR48=""
詳如 :7統_0_1884期_1883_名次比對用

1880~請修正下列儲存格~
W91=V
AP48=V；AR48=""
W99=V；AP99=""
詳如 :7統_0_1884期_1880_名次比對用

PS :
1_COUNTIF(C34:AY116,"V")=61個
2_BUG都是發生在D和E二欄的同名次不是同一列和同名次有2個(含)以上時~
請問 : D欄和E欄的名次是否有分別統計?

以上 懇請賜正。  謝謝您^^
[attach]33985[/attach]

---

作者: samwang    時間: 2021-9-6 21:35

本帖最後由 samwang 於 2021-9-6 21:45 編輯

回復 5# ziv976688


1883~請修正下列儲存格~
AP47=""；AR47=V
AP48=V；AR48=""
詳如 :7統_0_1884期_1883_名次比對用  
>> 請忽略#2程式碼，已重新更新如下紅字，請再測試看看，謝謝

Private Sub CommandButton1_Click()
Dim Path As String, A, Ar(1 To 1000, 1 To 2), Ar1(), Arr, Brr(1 To 7), Crr, xD, T%, i&, j&
Dim Ar2(), Drr(1 To 16, 1 To 49), Arr1,R%, K%, CR%, R1%
...
...
fileOrg = ActiveWorkbook.Name
If n1 > 0 Then
R = 33
    表頭 = Array("總次數", "最大", "次大", "三大", "", "最小", "次小", "三小", _
                  "倍數", "最大", "次大", "三大", "", "最小", "次小", "三小")
    For i1 = 0 To n - 1   '開啟Ar1
        Set WB = Workbooks.Open(Ar1(i1))
        fn = Split(Ar1(i1), "_")(5)
        With Sheets(1)
            If .FilterMode Then .ShowAllData
            With .Range(.[B1], .[E65536].End(3))
                Crr = .Value
                .Sort Key1:=.Item(3), Order1:=2, Header:=1
                Arr = .Value    '總次數
                .Sort Key1:=.Item(4), Order1:=1, Header:=1
                Arr1 = .Value   '倍數
                .Value = Crr
            End With
        End With
        WB.Close
        For i = 2 To 4                      '總次數:最大3數值
            ReDim Preserve Ar2(K): Ar2(K) = Arr(i, 1): K = K + 1
        Next
        For i = UBound(Arr) To 48 Step -1   '總次數:最小3數值
            ReDim Preserve Ar2(K): Ar2(K) = Arr(i, 1): K = K + 1
        Next
        For i = UBound(Arr1) To 48 Step -1  '倍數:最大3數值
            ReDim Preserve Ar2(K): Ar2(K) = Arr1(i, 1): K = K + 1
        Next
        For i = 2 To 4                      '倍數:最小3數值
            ReDim Preserve Ar2(K): Ar2(K) = Arr1(i, 1): K = K + 1
        Next
        For i = 0 To UBound(Ar2)
            T = Ar2(i)
            If CR = 3 Then CR = 0: R1 = R1 + 2 Else R1 = R1 + 1
            Drr(R1, T) = "V": CR = CR + 1
        Next
        With Sheets("Sheet1")
            .Range("a" & R) = fn
            .Range("b" & R).Resize(16) = Application.Transpose(表頭)
            .Range("c" & R + 1).Resize(15, 49) = Drr
            R = .[b65536].End(3).Row + 2
        End With
        Erase Ar2: Erase Drr: K = 0: CR = 0: R1 = 0
    Next
End If
Set fs = Nothing: Set f = Nothing: Set fc = Nothing
...
...

---

作者: ziv976688    時間: 2021-9-6 22:36

本帖最後由 ziv976688 於 2021-9-6 22:54 編輯

回復 6# samwang
謝謝您的賜正   
測試結果 :
不好意思，尚有一處有遺漏~
1880~
總次數的三小有2個~21和40(中式排名~"同名次" >=1個時，都要記錄)
W91  沒有記錄到
所以~
W91=V
懇請您賜正。
謝謝您
[attach]33987[/attach]

---

作者: samwang    時間: 2021-9-7 10:06

回復 7# ziv976688


不好意思，沒有想到這麼複雜，那就只能每次大小分開計算，因為每組大小裡面的數據都有可能重複且可能n筆重複資料，對吧?   

例如: 總次數最大數值，數值: 21(最大)、40(2st)、41(2st)、42(3st) 或  21(最大)、40(2st)、41(3st)、42(3st) 或 ....

---

作者: ziv976688    時間: 2021-9-7 10:34

本帖最後由 ziv976688 於 2021-9-7 10:51 編輯

回復 8# samwang
您太客氣了!您已經幫我很多忙了~謝謝您

不是說"教學相長"嗎?
我們都耐心等等~
看還有沒有其他高手願意幫忙和指導。

---

作者: samwang    時間: 2021-9-7 11:29

回復 7# ziv976688


總次數的三小有2個~21和40(中式排名~"同名次" >=1個時，都要記錄)
W91  沒有記錄到
>> 因為前3大小有重複值，所以分開統計比對資料，更新如下，請再測試看看，謝謝   

Private Sub CommandButton1_Click()
Dim Path As String, A, Ar(1 To 1000, 1 To 2), Ar1(), Arr, Brr(1 To 7), Crr, xD, T%, i&, j&
Dim Drr(1 To 3, 1 To 49), Arr1, R%, K21%, K22%, K31%, K32%, R21%, R22%, R31%, R32%, T1%
Dim Ar21(1 To 10, 1 To 2), Ar22(1 To 10, 1 To 2), Ar31(1 To 10, 1 To 2), Ar32(1 To 10, 1 To 2)
Set xD = CreateObject("Scripting.Dictionary")
...
...
If n1 > 0 Then
R = 33
     表頭 = Array("總次數", "最大", "次大", "三大", "", "最小", "次小", "三小", _
                   "倍數", "最大", "次大", "三大", "", "最小", "次小", "三小")
     For i1 = 0 To n - 1   '開啟Ar1
         Set WB = Workbooks.Open(Ar1(i1))
         fn = Split(Ar1(i1), "_")(5)
         With Sheets(1)
             If .FilterMode Then .ShowAllData
             With .Range(.[B1], .[E65536].End(3))
                 Crr = .Value
                 .Sort Key1:=.Item(3), Order1:=2, Header:=1
                 Arr = .Value    '總次數
                .Sort Key1:=.Item(4), Order1:=2, Header:=1
                 Arr1 = .Value   '倍數
                .Value = Crr
             End With
         End With
         WB.Close
         For i = 2 To UBound(Arr)           '總次數:最大3數值
            K21 = K21 + 1: If K21 > 3 And xD(Arr(i, 3) & "_21") <> 1 Then Exit For
            Ar21(K21, 1) = Arr(i, 1): Ar21(K21, 2) = Arr(i, 3): xD(Arr(i, 3) & "_21") = 1
         Next
         For i = UBound(Arr) To 2 Step -1   '總次數:最小3數值
            K22 = K22 + 1: If K22 > 3 And xD(Arr(i, 3) & "_22") <> 1 Then Exit For
            Ar22(K22, 1) = Arr(i, 1): Ar22(K22, 2) = Arr(i, 3): xD(Arr(i, 3) & "_22") = 1
         Next
         For i = 2 To UBound(Arr1)          '倍數:最大3數值
            K31 = K31 + 1: If K31 > 3 And xD(Arr1(i, 4) & "_31") <> 1 Then Exit For
            Ar31(K31, 1) = Arr1(i, 1): Ar31(K31, 2) = Arr1(i, 4): xD(Arr1(i, 4) & "_31") = 1
         Next
        For i = UBound(Arr1) To 2 Step -1   '倍數:最小3數值
            K32 = K32 + 1: If K32 > 3 And xD(Arr1(i, 4) & "_32") <> 1 Then Exit For
            Ar32(K32, 1) = Arr1(i, 1): Ar32(K32, 2) = Arr1(i, 4): xD(Arr1(i, 4) & "_32") = 1
         Next
         
         With Sheets("Sheet1")
            .Range("a" & R) = fn
            .Range("b" & R).Resize(16) = Application.Transpose(表頭)
            For i = 1 To K21 - 1  '總次數:最大3數值
                T = Ar21(i, 2): If T1 = T Then R21 = R21 Else R21 = R21 + 1
                Drr(R21, Ar21(i, 1)) = "V": T1 = T
            Next
            .Range("c" & R + 1).Resize(3, 49) = Drr
            R = .[b65536].End(3).Row - 10: Erase Drr: T1 = 0
            For i = 1 To K22 - 1  '總次數:最小3數值
                T = Ar22(i, 2): If T1 = T Then R22 = R22 Else R22 = R22 + 1
                Drr(R22, Ar22(i, 1)) = "V": T1 = T
            Next
            .Range("c" & R).Resize(3, 49) = Drr
            R = .[b65536].End(3).Row - 6: Erase Drr: T1 = 0
            
            For i = 1 To K31 - 1  '倍數:最大3數值
                T = Ar31(i, 2): If T1 = T Then R31 = R31 Else R31 = R31 + 1
                Drr(R31, Ar31(i, 1)) = "V": T1 = T: T1 = 0
            Next
            .Range("c" & R).Resize(3, 49) = Drr
            R = .[b65536].End(3).Row - 2: Erase Drr: T1 = 0
            For i = 1 To K32 - 1  '倍數:最小3數值
                T = Ar32(i, 2): If T1 = T Then R32 = R32 Else R32 = R32 + 1
                Drr(R32, Ar32(i, 1)) = "V": T1 = T: T1 = 0
            Next
            .Range("c" & R).Resize(3, 49) = Drr
            R = .[b65536].End(3).Row + 2: Erase Drr: T1 = 0
         End With
         Erase Ar21: Erase Ar22: Erase Ar31: Erase Ar32: xD.RemoveAll
         K21 = 0: K22 = 0: K31 = 0: K32 = 0: R21 = 0: R22 = 0: R31 = 0: R32 = 0
     Next
End If
Set fs = Nothing: Set f = Nothing: Set fc = Nothing
...
...

---

作者: samwang    時間: 2021-9-7 13:51

回復 7# ziv976688


不好意思，更新10# 部分程式碼如下，謝謝

WB.Close
         For i = 2 To UBound(Arr)           '總次數:最大3數值
            K21 = K21 + 1: If xD.Count > 2 And xD(Arr(i, 3)) <> 1 Then Exit For
            Ar21(K21, 1) = Arr(i, 1): Ar21(K21, 2) = Arr(i, 3): xD(Arr(i, 3)) = 1
         Next
         xD.RemoveAll
         For i = UBound(Arr) To 2 Step -1   '總次數:最小3數值
            K22 = K22 + 1: If xD.Count > 2 And xD(Arr(i, 3)) <> 1 Then Exit For
            Ar22(K22, 1) = Arr(i, 1): Ar22(K22, 2) = Arr(i, 3): xD(Arr(i, 3)) = 1
         Next
         xD.RemoveAll
         For i = 2 To UBound(Arr1)          '倍數:最大3數值
            K31 = K31 + 1: If xD.Count > 2 And xD(Arr1(i, 4) & "_31") <> 1 Then Exit For
            Ar31(K31, 1) = Arr1(i, 1): Ar31(K31, 2) = Arr1(i, 4): xD(Arr1(i, 4)) = 1
         Next
         xD.RemoveAll
        For i = UBound(Arr1) To 2 Step -1   '倍數:最小3數值
            K32 = K32 + 1: If xD.Count > 2 And xD(Arr1(i, 4)) <> 1 Then Exit For
            Ar32(K32, 1) = Arr1(i, 1): Ar32(K32, 2) = Arr1(i, 4): xD(Arr1(i, 4)) = 1
         Next
         xD.RemoveAll
         
         With Sheets("Sheet1")
            .Range("a" & R) = fn

---

作者: ziv976688    時間: 2021-9-7 16:53

本帖最後由 ziv976688 於 2021-9-7 16:54 編輯

回復 11# samwang
不好意思~增添您許多麻煩~辛苦您了~謝謝您

測試結果 :
原先的BUG是解決了，但#11樓的貴解又產生其它的BUG~倍數的第3大跑不出來。
懇請賜正~謝謝您
為利您查閱~已將所有前3大和前3小的標示，做一個查詢表~請見有"統"字的各期檔案之備註欄。
[attach]33989[/attach]

---

作者: samwang    時間: 2021-9-7 19:19

回復 12# ziv976688

請以此為主，都不知道改了哪裡，因為有些是你原本貼錯的再加上我修改的，所以真的有點亂，
總之全部貼出來如下，請再測試看看，謝謝。

Private Sub CommandButton1_Click()
Dim xD, Ar21(1 To 10, 1 To 2), Ar22(1 To 10, 1 To 2), Ar31(1 To 10, 1 To 2), Ar32(1 To 10, 1 To 2)
Dim Path As String, A, Ar(1 To 1000, 1 To 2), Ar1(), Arr, Brr(1 To 7), Crr, T, i&, j&
Dim Drr(1 To 3, 1 To 49), Arr1, R%, K21%, K22%, K31%, K32%, R21%, R22%, R31%, R32%, T1
Set xD = CreateObject("Scripting.Dictionary")
   
    Nrange = "1884" ' InputBox("請輸入DATA!的開獎期數", "輸入期數")
    Order = "0" ' InputBox("請輸入增加的邏輯條件條件之起迄序號", "輸入序號(1~99)或不增加(按Enter)")
    Ncount = "1" ' InputBox("請輸入驗證版的連續次數", "輸入次數(1~10)")
   
    Tm = Timer
    [L1] = ""
    [L2] = ""
    [L3] = ""
Application.DisplayAlerts = False
Application.ScreenUpdating = False

Set fs = CreateObject("Scripting.FileSystemObject")
A = ThisWorkbook.Path     '每個資料夾名稱裝入Ar
Set f = fs.GetFolder(A)
Set fc = f.SubFolders
For Each f1 In fc
    n = n + 1
    Ar(n, 1) = f1.Path
    Ar(n, 2) = Split(Split(f1.Name, "_")(4), "-")(0)
Next
For i = 1 To UBound(Ar)   'Ar由大至小排序
For j = i + 1 To UBound(Ar)
    If Ar(i, 2) < Ar(j, 2) Then
        A = Ar(i, 1)
        Ar(i, 1) = Ar(j, 1)
        Ar(j, 1) = A
    End If
Next j
Next i

For i = 1 To n            '開啟Ar，找檔名有"統"裝入Ar1
    Set f = fs.GetFolder(Ar(i, 1))
    Set fc = f.Files
    For Each f1 In fc
        If InStr(f1.Path, "統") Then
            ReDim Preserve Ar1(n1)
            Ar1(n1) = f1.Path
            n1 = n1 + 1
        End If
    Next f1
Next i

fileOrg = ActiveWorkbook.Name
If n1 > 0 Then
R = 33
     表頭 = Array("總次數", "最大", "次大", "三大", "", "最小", "次小", "三小", _
                   "倍數", "最大", "次大", "三大", "", "最小", "次小", "三小")
     For i1 = 0 To n - 1   '開啟Ar1
         Set WB = Workbooks.Open(Ar1(i1))
         fn = Split(Ar1(i1), "_")(5)
         With Sheets(1)
             If .FilterMode Then .ShowAllData
             With .Range(.[B1], .[E65536].End(3))
                 Crr = .Value
                 .Sort Key1:=.Item(3), Order1:=2, Header:=1
                 Arr = .Value    '總次數
                .Sort Key1:=.Item(4), Order1:=2, Header:=1
                 Arr1 = .Value   '倍數
                .Value = Crr
             End With
         End With
         WB.Close
         For i = 2 To UBound(Arr)           '總次數:最大3數值
            K21 = K21 + 1: If xD.Count > 2 And Not xD.Exists(Arr(i, 3) & "") Then Exit For
            Ar21(K21, 1) = Arr(i, 1): Ar21(K21, 2) = Arr(i, 3): xD(Arr(i, 3) & "") = 1
         Next
         xD.RemoveAll
         For i = UBound(Arr) To 2 Step -1   '總次數:最小3數值
            K22 = K22 + 1: If xD.Count > 2 And Not xD.Exists(Arr(i, 3) & "") Then Exit For
            Ar22(K22, 1) = Arr(i, 1): Ar22(K22, 2) = Arr(i, 3): xD(Arr(i, 3) & "") = 1
         Next
         xD.RemoveAll
         For i = 2 To UBound(Arr1)          '倍數:最大3數值
            K31 = K31 + 1: If xD.Count > 2 And Not xD.Exists(Arr1(i, 4) & "") Then Exit For
            Ar31(K31, 1) = Arr1(i, 1): Ar31(K31, 2) = Arr1(i, 4): xD(Arr1(i, 4) & "") = 1
         Next
         xD.RemoveAll
        For i = UBound(Arr1) To 2 Step -1   '倍數:最小3數值
            K32 = K32 + 1: If xD.Count > 2 And Not xD.Exists(Arr1(i, 4) & "") Then Exit For
            Ar32(K32, 1) = Arr1(i, 1): Ar32(K32, 2) = Arr1(i, 4): xD(Arr1(i, 4) & "") = 1
         Next
         xD.RemoveAll
         
         With Sheets("Sheet1")
            .Range("a" & R) = fn
            .Range("b" & R).Resize(16) = Application.Transpose(表頭)
            For i = 1 To K21 - 1  '總次數:最大3數值
                T = Ar21(i, 2): If T1 = T Then R21 = R21 Else R21 = R21 + 1
                Drr(R21, Ar21(i, 1)) = "V": T1 = T
            Next
            .Range("c" & R + 1).Resize(3, 49) = Drr
            R = .[b65536].End(3).Row - 10: Erase Drr: T1 = 0
            
            For i = 1 To K22 - 1  '總次數:最小3數值
                T = Ar22(i, 2): If T1 = T Then R22 = R22 Else R22 = R22 + 1
                Drr(R22, Ar22(i, 1)) = "V": T1 = T
            Next
            .Range("c" & R).Resize(3, 49) = Drr
            R = .[b65536].End(3).Row - 6: Erase Drr: T1 = 0
            
            For i = 1 To K31 - 1  '倍數:最大3數值
                T = Ar31(i, 2): If T1 = T Then R31 = R31 Else R31 = R31 + 1
                Drr(R31, Ar31(i, 1)) = "V": T1 = T
            Next
            .Range("c" & R).Resize(3, 49) = Drr
            R = .[b65536].End(3).Row - 2: Erase Drr: T1 = 0
            
            For i = 1 To K32 - 1  '倍數:最小3數值
                T = Ar32(i, 2): If T1 = T Then R32 = R32 Else R32 = R32 + 1
                Drr(R32, Ar32(i, 1)) = "V": T1 = T  'If R32 < 4 Then:
            Next
            .Range("c" & R).Resize(3, 49) = Drr
            R = .[b65536].End(3).Row + 2: Erase Drr: T1 = 0
            
         End With
         Erase Ar21: Erase Ar22: Erase Ar31: Erase Ar32: xD.RemoveAll
         K21 = 0: K22 = 0: K31 = 0: K32 = 0: R21 = 0: R22 = 0: R31 = 0: R32 = 0
     Next
End If
Set fs = Nothing: Set f = Nothing: Set fc = Nothing '...................................................................
    Set xD = CreateObject("Scripting.Dictionary")
    With Sheets("Sheet1")
        .[A1] = Nrange
        .[A2].Formula = "=Count(A33:A2000) & ""期""": .[A2] = .[A2].Value 'A欄的期個數
        .[A3] = "開獎號碼"
        .[A4:A10].Formula = "=IF(A$1="""","""",VLOOKUP(A$1,DATA!$A:$H,ROW()-2,))": .[A4:A10] = .[A4:A10].Value  '=Nrange期數的開獎號碼
        .[A32] = "期數"

        .[C2:AY16].Formula = "=IF(SUMPRODUCT(SUBTOTAL(3,OFFSET(C34,ROW($1:$1017)*17-17,)))>0,SUMPRODUCT(SUBTOTAL(3,OFFSET(C34,ROW($1:$1017)*17-17,))),"""")": .[C2:AY16] = .[C2:AY16].Value 'C2:AY16的公式

'版面格式.........................................................
            With .Columns("A:AY")
                .Font.Name = "Verdana"  '字體
                .HorizontalAlignment = xlCenter  '左右置中
                .VerticalAlignment = xlCenter  '上下置中
                .EntireColumn.AutoFit  '自動欄寬
                .EntireRow.AutoFit  '自動列高
            End With
End With
'.....................................................................................
        Sheets("Sheet1").Copy
        ActiveWorkbook.SaveAs ThisWorkbook.Path & "\7前3大&小_" & Order & "_" & Nrange & "期_" & Sheets("Sheet1").[A2] & "_" & Ncount & "次" & ".xls"
        ActiveWindow.Close
    Application.Goto [DATA!J1]
[L1] = Nrange & "=" & Format((Timer - Tm) / 24 / 60 / 60, "hh:mm:ss")
[L2] = "增加的邏輯條件序號=" & Order
[L3] = "驗證版的連續次數= " & Ncount

End Sub

---

作者: ziv976688    時間: 2021-9-7 21:43

回復 13# samwang
測試成功(含前3大>=2個；前3小>=2個)
萬分感謝您熱心的幫忙和耐心指導~感恩

---

作者: samwang    時間: 2021-9-7 21:51

回復 14# ziv976688


  ２＿Ｖ的總數量目前是５８個（正確是６０個）∼5期*2欄*(前3大+前3小)>=60~
>> 我一直不解，這是什麼意思? 如何判斷?

---

作者: ziv976688    時間: 2021-9-7 22:05

本帖最後由 ziv976688 於 2021-9-7 22:22 編輯

回復 15# samwang
如果前3大和前3小都是各只有1個
期數=5期
總次數=1
倍數=1
前3大=3
前3小=3
所以~
5*(1+1)*(3+3)=60
再次謝謝您的耐心指導~受益良多。
辛苦了~感恩

---

歡迎光臨 麻辣家族討論版版 (http://forum.twbts.com/)