- 帖子
- 1446
- 主題
- 40
- 精華
- 0
- 積分
- 1470
- 點名
- 0
- 作業系統
- Windows 7
- 軟體版本
- Excel 2010 & 2016
- 閱讀權限
- 50
- 性別
- 男
- 來自
- 台灣
- 註冊時間
- 2020-7-15
- 最後登錄
- 2024-10-21
|
17#
發表於 2024-1-25 08:22
| 只看該作者
本帖最後由 Andy2483 於 2024-1-30 08:58 編輯
回復 16# jdg188
謝謝前輩回復,您提供範例是練習VBA字典的好題材
後學學習方案如下,請前輩指教 PS:這 31 號曾經連續50次不開出
 今彩_20240125.zip (113.56 KB)
執行結果:
Sub 開出次數統計3()
Dim Crr(1 To 6, 1 To 100), i%, j%, V%, xR As Range, D As Date, y%, ii%, S&, Z, T$, TT, M%
If UBound(Brr) < 100 Then Exit Sub
Set Z = CreateObject("Scripting.Dictionary")
Worksheets.Add after:=Worksheets(Sheets.Count): ActiveSheet.Name = "開出次數3"
Cells.Font.Name = "微軟正黑體": Cells.HorizontalAlignment = xlCenter: Set xR = [C1]
For i = UBound(Brr) To 100 Step -1
With xR.Resize(6, UBound(Crr, 2))
Range(.Rows(1), .Rows(1).Offset(, -2)).Borders.LineStyle = xlContinuous
Range(.Rows(1), .Rows(1).Offset(, -2)).Interior.ColorIndex = 19
For ii = 7 To 10: Range(.Cells, .Offset(, -2)).Borders(ii).Weight = 4: Next
Intersect(.Columns(1), .Columns(1).Offset(1)).Interior.ColorIndex = i Mod 15 + 33
End With
D = Brr(i, 2) + 1: S = Brr(i, 1) + 1
For j = 1 To 6
TT = T & "/": T = ""
For V = 1 To 100
Crr(1, V) = V - 1
For y = 2 To 6
If V = 1 Then T = T & "/" & Brr(i - V + 1, y + 1)
If Z(Val(Brr(i - V + 1, y + 1))) = 0 Then
Crr(y, V) = Brr(i - V + 1, y + 1)
Z(Val(Brr(i - V + 1, y + 1))) = 1
If InStr(TT, "/" & Val(Brr(i - V + 1, y + 1)) & "/") Then
xR(y, V).Interior.ColorIndex = 5: xR(y, V).Font.ColorIndex = 2
If M < V Then M = V
End If
End If
Next
Next
Next
With xR.Resize(6, UBound(Crr, 2)): .Value = Crr: xR(1, -1) = "期數 (日期)": End With
xR(2, -1).Resize(5).Merge: xR(2, -1) = S & " (" & D & ")": xR(2, -1).Font.Bold = True
xR(2, -1).Resize(5).Interior.ColorIndex = IIf(i = UBound(Brr), 38, 40)
Set xR = xR(7, 1): Z.RemoveAll: Erase Crr
Next
ActiveSheet.UsedRange.EntireColumn.AutoFit: [B:B].ColumnWidth = 2
ActiveSheet.UsedRange.Offset(, M + 2).EntireColumn.Delete
ActiveSheet.UsedRange.Borders(10).Weight = 4: ActiveWindow.Zoom = 85
ActiveSheet.UsedRange.Offset([C65536].End(3).Row).EntireRow.Delete
End Sub |
-
-
活頁簿2.zip
(6.1 KB)
這是傳錯的範例
|
