- 帖子
- 2035
- 主題
- 24
- 精華
- 0
- 積分
- 2031
- 點名
- 0
- 作業系統
- Win7
- 軟體版本
- Office2010
- 閱讀權限
- 100
- 性別
- 男
- 註冊時間
- 2012-3-22
- 最後登錄
- 2024-2-1
|
35#
發表於 2013-12-7 20:50
| 只看該作者
本帖最後由 c_c_lai 於 2013-12-7 20:51 編輯
回復 32# ML089
增修後之程式碼如下：- Option Explicit
- ' ML089 寫於 2013/12/7
- ' http://forum.twbts.com/viewthread.php?tid=10927&extra=&page=3
- Sub 連續0個數之統計()
- Dim dic As Object
- Dim t1 As Date, tt1 As Date, t2 As Date, tt2 As Date
- Dim Arr As Variant, xDebug As String, sRng As Range, WriteToRange As Range
- Dim i As Integer, c As Long, r As Long, y As Integer, rN As Long, cN As Long
- Dim Bins_array As Variant, ArrF As Variant, ArrN As Variant, MaxN As Double
-
- Application.Calculation = xlManual ' 關閉計算
- Application.ScreenUpdating = False ' 關閉顯示
- xDebug = InputBox("陣列計算資料寫出。填入 1 / 0 控制 :", "DeBug", 0) ' ◎陣列計算資料寫出。填入 1、Ture / 0、Flase 控制
- If xDebug Then ActiveSheet.Copy after:=ActiveSheet ' Test Use 1
- t1 = Timer: tt1 = Time ' 秒數計時器
- Set dic = CreateObject("Scripting.Dictionary")
- dic("連續位址") = "組合數量"
- ' ↓ 找 0，將每組連續 0 編不同序號
- ' Arr : Variant/Variant(1 to 20, 1 to 26)
- Arr = ActiveSheet.[A1].CurrentRegion ' 讀入陣列
-
- i = 0
- rN = UBound(Arr, 1) ' Y Rows 20
- cN = UBound(Arr, 2) ' X Columns 26
-
- For c = 1 To cN
- For r = 1 To rN ' 此迴圈將陣列非0值改為文字型態
- If Arr(r, c) <> 0 Then Arr(r, c) = "X" ' Empty 會被視為 0，"" 不會
- Next
- Next
- For c = 1 To cN
- For r = 1 To rN ' 此迴圈找 0
- If Arr(r, c) = 0 Then
- i = i + 1
- Set sRng = Sheets("TEST2").Cells(r, c)
- Call xRep(Arr, r, c, i, sRng)
- dic(sRng.Address) = Range(sRng.Address).Count
- End If
- Next
- Next
- If xDebug Then [A1].Resize(rN, cN) = Arr ' Test Use 2 ' i = 11
- ' ↓ 計算每組個數。 注意! Frequency 回傳 i + 1 組，所先將 i - 1
- Bins_array = Application.Evaluate("Row(1:" & i - 1 & ")") ' i = 11
- ' 計算某一個範圍內的值出現的次數，並傳回一個垂直數值陣列。
- ' 例如，用 FREQUENCY 來計算某些範圍內的考試成績各有幾個人。
- ' 由於 FREQUENCY 傳回陣列，因此必須輸入為陣列公式。
- ArrN = Application.Frequency(Arr, Bins_array)
- MaxN = Application.Max(ArrN) ' MaxN : 62 : Variant/Double (以上統計數的最大值)
- ' ↓ 統計每組個數。 注意! Frequency 回傳 i + 1 組，所先將 MaxN - 1
- Bins_array = Application.Evaluate("Row(1:" & MaxN - 1 & ")")
- ArrF = Application.Frequency(ArrN, Bins_array)
- ' ↓ 寫出資料
- Set WriteToRange = ActiveSheet.Cells(rN + 3, 1)
- WriteToRange.CurrentRegion.ClearContents
- Application.Goto Reference:=WriteToRange, scroll:=True ' 將畫面切換至 WriteToRange。
- With WriteToRange
- .Resize([A:A].Rows.Count - rN - 3, 2) = ""
- .Resize(1, 2) = Application.Evaluate("{""連續數"", "";組數""}")
- y = 0
- For i = 1 To MaxN
- If ArrF(i, 1) <> 0 Then
- y = y + 1
- .Offset(y, 0) = i
- .Offset(y, 1) = ArrF(i, 1)
- End If
- Next
- .Offset(0, 2).Resize(dic.Count, 1) = Application.Transpose(dic.keys)
- .Offset(0, 3).Resize(dic.Count, 1) = Application.Transpose(dic.items)
-
- t2 = Timer: .Offset(y + 1, 1) = Format(t2 - t1, "0.00") & " 秒"
- tt2 = Time: .Offset(y + 2, 1) = Format((tt2 - tt1) * 24 * 60 * 60, "0.00") & " 秒"
- End With
- Set Arr = Nothing ' 釋放記憶體
- Set dic = Nothing
-
- Application.ScreenUpdating = True
- Application.Calculation = xlCalculationAutomatic
- End Sub
- ' 遞迴呼叫( recursive call )查詢，將連續0寫入同一編號
- Sub xRep(ByRef Arr, r, c, i, ByRef rng As Range)
- Dim Temp As Range
-
- Arr(r, c) = i ' 寫入編號
- Cells(r, c).Interior.ColorIndex = 6 ' Test Use 3
- Set Temp = Union(rng, Sheets("TEST2").Cells(r, c))
- On Error Resume Next ' 避免邊界錯誤
- If Arr(r - 1, c) = 0 Then Call xRep(Arr, r - 1, c, i, Temp) ' 找上
- If Arr(r + 1, c) = 0 Then Call xRep(Arr, r + 1, c, i, Temp) ' 找下
- If Arr(r, c - 1) = 0 Then Call xRep(Arr, r, c - 1, i, Temp) ' 找左
- If Arr(r, c + 1) = 0 Then Call xRep(Arr, r, c + 1, i, Temp) ' 找右
- Set rng = Temp
- End Sub
|
|
發表於 2013-12-7 20:07
| 
