- 帖子
- 678
- 主題
- 147
- 精華
- 0
- 積分
- 799
- 點名
- 0
- 作業系統
- win 8
- 軟體版本
- MS 2003
- 閱讀權限
- 50
- 性別
- 男
- 註冊時間
- 2016-2-9
- 最後登錄
- 2022-1-20
|
12#
發表於 2021-8-22 10:28
| 只看該作者
本帖最後由 ziv976688 於 2021-8-22 10:40 編輯
回復 10# samwang
感謝您的指導^^
 TEST_0822_s1.rar (24.92 KB)
不好意思，"新增需求"的程式碼~我放置的位列~不知道是哪裡有誤置?
所以在列47會產生偵錯^^"
If Arr(i, 3) > 0 Then Arr(i, 4) = Arr(i, 3) / Arr(i, 2)
尚請勞駕您賜正。謝謝您!
Private Sub CommandButton1_Click()
Dim Arr, Brr(1 To 7), Crr, xD, T%, i&, j&
Nrange = "1878" ' InputBox("請輸入DATA!的開獎期數", "輸入期數")
Tm = Timer
[L1] = ""
Application.DisplayAlerts = False
Set xD = CreateObject("Scripting.Dictionary")
With Sheets("Sheet1")
.[A1] = Nrange
T = .[A1]
Arr = Range([DATA!h1], [DATA!a65536].End(3))
For i = 2 To UBound(Arr)
If Arr(i, 1) = T Then
For j = 2 To 8: n = n + 1: Brr(n) = Arr(i, j): Next
End If
Next
.[A2] = ((.Cells(1, 256).End(xlToLeft).Column - 12) / 2) & "個"
.[A3] = "開獎號碼"
.[A4].Resize(7) = Application.Transpose(Brr)
For i = 1 To 49 'B欄
.Range("B" & i + 1) = i
Next
R = .Columns("M:DF").Find("*", , , , , 2).Row
Arr = .Range("M1:DF" & R)
For j = 1 To UBound(Arr, 2) Step 2
For i = 2 To UBound(Arr)
T = Arr(i, j): If T = 0 Then GoTo 98
xD(T & "/1") = xD(T & "/1") + 1
xD(T & "/2") = xD(T & "/2") + Arr(i, j + 1)
Next i
98: Next j
Arr = .Range(.[C1], .[B65536].End(3))
For i = 2 To UBound(Arr)
For j = 1 To 2: Arr(i - 1, j) = xD(Arr(i, 1) & "/" & j): Next
If xD(Arr(i, 1) & "/1") = "" Then Arr(i - 1, 1) = 0: Arr(i - 1, 2) = 0 '要新增
Next
.[C2].Resize(UBound(Arr) - 1, 2) = Arr 'C&D欄
Arr = .Range(.[B2], .[e65536].End(3))
ReDim Crr(1 To UBound(Arr), 1 To 5)
For i = 1 To UBound(Arr)
If Arr(i, 3) > 0 Then Arr(i, 4) = Arr(i, 3) / Arr(i, 2)
Crr(i, 1) = Arr(i, 2): Crr(i, 2) = Arr(i, 2)
Crr(i, 3) = Arr(i, 1): Crr(i, 4) = Arr(i, 3)
Crr(i, 5) = Arr(i, 4)
Next
.[B2].Resize(UBound(Arr), 4) = Arr
With .Range("g2").Resize(UBound(Crr), 5)
.Value = Crr
.Sort key1:=.Item(1), Order1:=2, Header:=xlNo
Crr = .Value
End With
T = Application.Max(.Range("g2:g" & UBound(Crr)))
For i = 1 To UBound(Crr)
Crr(i, 1) = T - Crr(i, 1) + 1
Next
.[H2].Resize(UBound(Crr), 1) = Crr
'版面格式.........................................................
With .Columns("A:DF")
.Font.Name = "Verdana" '字體
.HorizontalAlignment = xlCenter '左右置中
.VerticalAlignment = xlCenter '上下置中
.EntireColumn.AutoFit '自動欄寬
.EntireRow.AutoFit '自動列高
End With
End With
Sheets("Sheet1").Copy
ActiveWorkbook.SaveAs ThisWorkbook.Path & "\7C_0_" & Nrange & "期_" & Sheets("Sheet1").[A2] & ".xls"
ActiveWindow.Close
Application.Goto [DATA!J1]
[L1] = Nrange & "=" & Format((Timer - Tm) / 24 / 60 / 60, "hh:mm:ss")
End Sub |
|
