- 帖子
- 976
- 主題
- 7
- 精華
- 0
- 積分
- 1018
- 點名
- 0
- 作業系統
- Win10
- 軟體版本
- Office 2016
- 閱讀權限
- 50
- 性別
- 男
- 註冊時間
- 2013-4-19
- 最後登錄
- 2024-12-18
|
13#
發表於 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 |
|
