Board logo

標題: [發問] 請教要如何使用 VBA 判別不規則儲存格的辦法2 [打印本頁]
作者: c_c_lai    時間: 2013-12-5 07:55     標題: 請教要如何使用 VBA 判別不規則儲存格的辦法2

因使用 FireFox、IE、 Google Chrome 等工具上傳圖片及測試檔案
都無法順利完成執行 (一片空白，且無法回到原畫面)，所以再次
另起爐灶。
不是要計算,是要統計,第一個工作表有"0"部份的面積,

1個0組成的面積 :有多少個?
2個0組成的面積：有多少個
3個0組成的面積 有多少個
.
.
50個0組成的面積：有多少個?
.
要利用統計出來的數據,製成像折線的圖表。
第一工作表數字是從第二工作表圖片轉換來的
0 跟255 是代表第二工作表圖片 顏色的數字
敬請大家指教，謝謝！
  1. 255        255        255        255        255        255        255        255        255        255        255        255        255        255        255        255        255        255        255        255        255        255        255        255        255        255        255
  2. 255        255        255        255        255        255        255        255        255        255        255        255        255        255        255        255        255        255        255        255        255        255        255        255        255        255        255
  3. 255        255        255        255        255        255        255        255        255        255        255        255        255        255        255        255        255        255        255        255        255        255        255        255        255        255        255
  4. 255        255        255        255        255        255        255        255        255        255        255        255        255        255        255        255        255        255        255        255        255        255        255        255        255        255        255
  5. 255        255        255        255        255        255        255        255        255        255        255        255        255        255        255        255        255        255        255        255        255        255        255        255        255        255        255
  6. 255        255        255        255        255        255        255        255        255        255        255        255        255        255        255        255        255        0        0        255        255        255        255        255        255        255        255
  7. 0        0        0        255        255        255        255        255        255        255        255        255        255        255        255        255        0        0        0        0        0        255        255        255        255        255        255
  8. 0        0        0        255        255        255        255        255        255        255        255        255        255        255        255        255        255        0        0        0        0        255        255        255        255        255        255
  9. 0        0        0        0        0        0        0        255        255        255        255        255        255        255        255        255        0        0        0        0        255        255        255        255        255        255        255
  10. 0        0        0        0        0        0        0        255        255        255        255        255        255        255        255        255        255        0        0        0        0        255        255        255        255        255        255
  11. 0        0        0        0        0        0        0        0        255        255        255        255        255        255        255        255        0        0        0        0        255        255        255        255        255        255        255
  12. 0        0        0        0        0        0        0        255        255        255        255        255        255        255        255        0        0        0        0        255        255        255        255        255        255        255        255
  13. 0        0        0        0        0        0        255        255        255        255        255        255        255        255        255        255        0        0        0        0        255        255        255        255        255        255        255
  14. 0        0        0        0        0        0        0        255        255        255        255        255        255        255        255        0        0        0        0        255        255        255        255        255        255        255        255
  15. 0        0        255        255        0        255        255        255        255        255        255        255        255        255        255        255        255        255        255        255        255        255        255        255        255        255        255
  16. 255        255        255        255        255        255        255        255        255        255        255        255        255        255        255        255        255        255        255        255        255        255        255        255        255        255        255
  17. 255        255        255        255        255        255        255        255        255        255        255        255        255        255        255        255        255        255        255        255        255        255        255        255        255        255        255
  18. 255        255        255        255        255        255        255        255        255        255        255        255        255        255        255        255        255        255        255        255        255        255        255        255        255        255        255
  19. 255        255        255        255        255        255        255        255        255        255        255        255        255        255        255        255        255        255        255        255        255        255        255        255        255        255        255
  20. 255        255        255        255        255        255        255        255        255        255        255        255        255        255        255        255        255        255        255        255        255        255        255        255        255        255        255
  21. 255        255        255        255        255        255        255        255        255        255        255        255        255        255        255        255        255        255        255        255        255        255        255        255        255        255        255
  22. 255        255        255        255        255        255        255        255        255        255        255        255        255        255        255        255        255        255        255        255        255        255        255        255        255        255        255
  23. 0        255        255        255        255        255        255        255        255        255        255        255        255        255        255        255        255        255        255        255        255        255        255        0        0        0        0
  24. 255        255        255        255        255        255        255        255        255        255        255        0        0        255        255        255        255        255        255        255        255        255        255        0        0        0        0
  25. 255        255        255        255        255        255        255        255        255        255        255        255        0        0        255        255        255        255        255        255        255        255        0        0        0        0        0
  26. 255        255        255        255        255        255        255        255        255        255        255        255        255        0        0        255        255        255        255        255        255        0        0        0        0        0        0
  27. 255        255        255        255        255        255        255        255        255        255        255        255        255        255        255        255        255        255        255        255        255        255        0        0        0        0        0
  28. 255        255        255        255        255        255        255        255        255        255        255        255        255        255        255        255        255        255        255        255        255        0        0        0        0        0        0
  29. 255        255        255        255        255        255        255        255        255        255        255        255        255        255        255        255        255        255        255        255        255        255        0        0        0        0        0
  30. 255        255        255        255        255        255        255        255        255        255        255        255        255        255        255        255        255        255        255        255        255        0        0        0        0        0        0
  31. 255        255        255        255        255        255        255        255        255        255        255        0        255        255        255        255        255        255        255        255        255        255        0        0        0        0        255
  32. 255        255        255        255        255        255        255        255        255        255        255        0        0        255        255        255        255        255        255        255        255        255        255        0        0        255        255
  33. 255        255        255        255        255        255        255        255        255        255        255        255        0        0        255        255        255        255        255        255        255        255        255        255        255        255        255
  34. 255        255        255        255        255        255        255        255        255        255        255        255        255        255        255        255        255        255        255        255        255        255        255        255        255        255        255
  35. 255        255        255        255        255        255        255        255        255        255        255        255        255        255        255        255        255        255        255        255        255        255        255        255        255        255        255
  36. 255        255        255        255        255        255        255        0        0        255        255        255        255        255        255        255        255        255        255        255        255        255        255        255        255        255        255
  37. 255        255        255        255        255        255        0        0        0        0        255        255        255        255        255        255        255        255        255        255        255        255        255        255        255        255        255
  38. 255        255        255        255        255        255        255        0        0        0        0        255        255        255        255        255        255        255        255        255        255        255        255        255        255        255        255
  39. 255        255        255        255        255        255        255        255        255        255        255        255        255        255        255        255        255        255        255        255        255        255        255        255        255        255        255
  40. 255        255        255        255        255        255        255        255        255        255        255        255        255        255        255        255        255        255        255        255        255        255        255        255        255        255        255
  41. 0        0        0        0        255        255        255        255        255        255        255        255        255        255        255        255        255        255        255        255        255        255        255        255        255        255        255
  42. 0        0        0        0        0        255        255        255        255        255        255        255        255        255        255        255        255        255        255        255        255        255        255        255        255        255        255
  43. 0        0        0        0        255        255        255        255        255        255        255        255        255        255        255        255        255        255        255        255        255        255        255        255        255        255        255
  44. 0        0        0        0        0        255        255        255        255        255        255        255        255        255        255        255        255        255        255        255        255        255        255        255        255        255        255
  45. 0        0        0        0        255        255        255        255        255        255        255        255        255        255        255        255        255        255        255        255        255        255        255        255        255        255        255
  46. 0        0        0        255        255        255        255        255        255        255        255        255        255        255        255        255        255        255        255        255        255        255        255        255        255        255        255
  47. 0        0        0        0        0        0        0        0        255        255        255        255        255        255        255        255        255        255        255        255        255        255        255        255        255        255        255
  48. 0        0        0        0        0        0        0        0        0        255        255        255        255        255        255        255        255        255        255        255        255        255        255        255        0        255        255
  49. 0        0        0        255        255        0        0        0        255        255        255        255        255        255        255        255        255        255        255        255        255        255        255        0        255        255        255
  50. 0        0        255        255        255        0        0        255        255        255        255        255        255        255        255        255        255        255        255        255        255        255        255        0        0        255        255
  51. 0        0        255        255        255        255        255        255        255        255        255        255        255        255        255        255        255        255        255        255        255        255        255        255        255        255        255
  52. 255        255        255        255        255        255        255        255        255        255        255        255        255        255        255        255        255        255        255        255        255        255        255        255        255        255        255
  53. 255        255        255        255        255        255        255        255        255        255        255        255        255        255        255        255        255        255        255        255        255        255        255        255        255        255        255
  54. 255        255        255        255        255        255        255        255        255        255        255        255        255        255        255        255        255        255        255        255        255        255        255        255        255        255        255
  55. 255        255        255        255        255        255        255        255        255        255        255        255        255        255        255        255        255        255        255        255        255        255        255        255        255        255        255
  56. 0        0        0        0        0        255        255        255        255        255        255        255        255        255        255        255        255        255        255        255        255        255        255        255        255        255        255
  57. 0        0        0        0        0        0        255        255        255        255        255        255        255        255        255        255        255        255        255        255        0        0        0        0        0        0        0
  58. 0        0        0        0        0        0        0        255        255        255        255        255        255        255        255        255        255        255        255        0        0        0        0        0        0        0        0
  59. 0        0        0        0        0        0        0        255        255        255        255        255        255        255        255        255        255        255        255        0        0        0        0        0        0        0        0
  60. 0        0        0        0        0        0        0        255        255        255        255        255        255        255        255        255        255        255        255        0        0        0        0        0        0        0        0
  61. 0        0        0        0        0        0        255        255        255        255        255        255        255        255        255        255        255        255        255        255        255        255        0        0        0        0        0
  62. 0        0        0        0        0        255        255        255        255        255        255        255        255        255        255        255        255        255        255        255        255        0        0        0        0        0        0
  63. 0        0        255        255        255        255        255        255        255        255        255        255        255        255        255        255        255        255        255        255        255        255        255        255        255        255        255
  64. 255        255        255        255        255        255        255        255        255        255        255        255        255        255        255        255        255        255        255        255        255        255        255        255        255        255        255
  65. 255        255        255        255        255        255        255        255        255        255        255        255        255        255        255        255        255        255        255        255        255        255        255        255        255        255        255
複製代碼
作者: c_c_lai    時間: 2013-12-5 07:59

回復 1# c_c_lai
真奇怪！ 之前欲上傳的附件於此次發文，竟然莫名地自動全部出現了，
實在太好了。
作者: c_c_lai    時間: 2013-12-5 08:08

回復 2# c_c_lai
對不起！ 有關 luhpro 等大大的回文，
我在原發文 "請教要如何使用 VBA 判別不規則儲存格的辦法"中
看不到 (有收到"消息"、但進去欲拜讀時卻無此相關回文內容)，
敬請再次賜教，謝謝你等。
作者: stillfish00    時間: 2013-12-5 13:46

回復 1# c_c_lai
寫得挺亂的，包涵哈~
d1字典 : Address , 面積
d2字典 : 面積 , 個數
依需求再自己改改吧
  1. Sub test()
  2.   Dim d1, d2, bCombine As Boolean, lCol As Long
  3.   Dim stripe As Range, stripeOffset As Range, rngTarget As Range
  4.   
  5.   Set d1 = CreateObject("scripting.dictionary")
  6.   With Sheets(1).[A1].CurrentRegion
  7.     .Replace What:="0", Replacement:=""
  8.     For lCol = 1 To .Columns.Count
  9.       If Application.CountA(.Columns(lCol).Cells) < .Columns(lCol).Cells.Count Then
  10.         For Each stripe In .Columns(lCol).SpecialCells(xlCellTypeBlanks).Areas
  11.           If stripe.Column = 1 Then
  12.             Set stripeOffset = stripe
  13.           Else
  14.             Set stripeOffset = .Parent.Range(stripe.Address).Offset(0, -1)
  15.           End If
  16.           bCombine = False
  17.           For Each prev In d1.keys
  18.             If Not Application.Intersect(.Parent.Range(prev), stripeOffset) Is Nothing Then
  19.               If d1.exists(stripe.Address) Then d1.Remove (stripe.Address)
  20.               Set stripe = Union(.Parent.Range(prev), stripe)
  21.               d1.Remove prev
  22.               d1(stripe.Address) = stripe.Count
  23.               Set stripeOffset = Union(stripeOffset, .Parent.Range(prev))
  24.               bCombine = True
  25.             End If
  26.           Next prev
  27.           If Not bCombine Then d1(stripe.Address) = stripe.Count
  28.         Next stripe
  29.       End If
  30.     Next lCol
  31.     .Replace What:="", Replacement:="0"
  32.   End With
  33.   
  34.   Set d2 = CreateObject("scripting.dictionary")
  35.   For Each x In d1.items
  36.     If d2.exists(x) Then
  37.       d2(x) = d2(x) + 1
  38.     Else
  39.       d2(x) = 1
  40.     End If
  41.   Next
  42.   For Each x In d2.keys
  43.     Debug.Print "面積 " & x & " : " & d2(x) & "個"
  44.   Next
  45. End Sub
複製代碼
作者: c_c_lai    時間: 2013-12-5 20:28

回復 4# stillfish00
不好意思，RUN 到現在已經過 半個多小時 (無回應)，
可能檔案太大了吧，明日我再試試，謝謝你！
作者: c_c_lai    時間: 2013-12-6 09:32

回復 4# stillfish00
我稍稍修改了處裡的範圍：
假設 lCol 目前值 為 1
  1. '  Sheets(1).Columns(lCol).Cells.Count : 65536
  2. '  Sheets(1).Range(Chr(64 + lCol) & Sheets(1).Rows.Count).End(xlUp).Row : 960
  3. '  Application.CountA(.Columns(lCol).Cells) : 861
複製代碼
將處裡的範圍予以縮小，以避免耗時處裡：
  1. '  If Application.CountA(.Columns(lCol).Cells) < .Columns(lCol).Cells.Count Then
  2. If Application.CountA(.Columns(lCol).Cells) < .Range(Chr(64 + lCol) & .Rows.Count).End(xlUp).Row Then
複製代碼
目前在執行過程中會出現 1004 的錯誤訊息，所以還在 Debug 中。
(應用程式或物件定義上的錯誤)
謝謝你！
作者: stillfish00    時間: 2013-12-6 09:42

回復 6# c_c_lai
跑的範圍大概多大呢(幾乘幾) ? 有檔案嗎?
我知道我的方法效率很差的，
因為我的作法是分columns，每個columns再分為數個帶狀連續的0，
然後才依這帶狀0 去判斷結合起來，
因為我也沒想到有甚麼好方法
作者: c_c_lai    時間: 2013-12-6 10:14

回復 7# stillfish00
#1 上的附件 "面積大小分佈統計.rar"  (109.12 KB)
不知道你能否完整下載下來？
真麻煩你了！
作者: c_c_lai    時間: 2013-12-6 10:19

回復 7# stillfish00
另外，
  1. If Not Application.Intersect(.Parent.Range(prev), stripeOffset) Is Nothing Then
複製代碼
我將它改成
  1. If Not Application.Intersect(Range(prev), stripeOffset) Is Nothing Then
複製代碼
不知對否？ 如此它才能判斷
  1. '     Application.Intersect(Range(prev), stripeOffset) : Nothing : Object
複製代碼
作者: stillfish00    時間: 2013-12-6 10:22

回復 8# c_c_lai
我的能跑 ，結果如下
面積 1 : 140個
面積 2 : 178個
面積 3 : 53個
面積 6 : 36個
面積 5 : 39個
面積 10 : 27個
面積 18 : 8個
面積 11 : 13個
面積 15 : 9個
面積 21 : 7個
面積 45 : 2個
面積 13 : 15個
面積 8 : 30個
面積 51 : 3個
面積 23 : 4個
面積 32 : 11個
面積 54 : 5個
面積 31 : 4個
面積 33 : 2個
面積 22 : 14個
面積 86 : 2個
面積 4 : 56個
面積 24 : 13個
面積 12 : 15個
面積 17 : 8個
面積 7 : 38個
面積 49 : 6個
面積 93 : 1個
面積 35 : 1個
面積 122 : 1個
面積 19 : 12個
面積 50 : 1個
面積 109 : 1個
面積 9 : 25個
面積 46 : 3個
面積 60 : 2個
面積 37 : 2個
面積 28 : 9個
面積 40 : 4個
面積 26 : 3個
面積 41 : 4個
面積 14 : 9個
面積 16 : 13個
面積 30 : 3個
面積 87 : 1個
面積 48 : 2個
面積 29 : 4個
面積 72 : 4個
面積 20 : 10個
面積 77 : 1個
面積 84 : 1個
面積 128 : 1個
面積 61 : 2個
面積 39 : 2個
面積 78 : 1個
面積 59 : 1個
面積 81 : 1個
面積 56 : 2個
面積 102 : 2個
面積 36 : 1個
面積 25 : 6個
面積 34 : 4個
面積 38 : 3個
面積 100 : 3個
面積 91 : 1個
面積 75 : 1個
面積 42 : 1個
面積 89 : 1個
面積 85 : 1個
面積 27 : 1個
面積 96 : 1個
面積 108 : 1個
面積 66 : 1個
面積 82 : 1個
面積 53 : 2個
面積 63 : 1個
面積 55 : 1個
面積 119 : 1個
面積 381 : 1個
作者: stillfish00    時間: 2013-12-6 10:26

回復 9# c_c_lai
.Parent 是指到 前面 With Sheets(1).[A1].CurrentRegion 的 parent 也就是 sheets(1)
直接用 Range(prev) ，應該相當於ActiveSheet.Range(prev)，照道理是沒啥影響。
作者: ML089    時間: 2013-12-6 12:30

本帖最後由 ML089 於 2013-12-6 12:31 編輯

回復 1# c_c_lai

請問檔案案中有圖片，如何將圖片的圖形轉成 0, 255數字

算0的面積，我初步算完有381組(也不知道對不對還沒有驗算)，其中有很多組是 0，需要把0組過濾掉嗎?
有標準答案可以給我驗證媽?
作者: Hsieh    時間: 2013-12-6 15:05

回復 2# c_c_lai
資料量龐大，且因為各個儲存格必須要以遞迴方式測是連續與否
跑的有點久
用縮小資料量先行測試應該還OK，你測試看看
[attach]16979[/attach]
作者: c_c_lai    時間: 2013-12-6 17:14

回復 12# ML089
不好意思現在才回來！
那張圖片只是樣張而已，
我個人亦在探索中，那是我另一友人的提問，
也多蒙各位鼎力協助，希望能從中找出頭緒。
作者: c_c_lai    時間: 2013-12-6 17:17

回復 13# Hsieh
謝謝您！
待測出結果後再行向您報告。
作者: ML089    時間: 2013-12-6 18:25

回復 14# c_c_lai

請問連在一起得原則是什麼，請看圖中說明

[attach]16982[/attach]
作者: c_c_lai    時間: 2013-12-6 20:51

回復 13# Hsieh
回復 16# ML089
回復 11# stillfish00
謝謝大家，終於測試出結果了，雖然速度上稍稍慢了點：
[attach]16983[/attach]
[attach]16984[/attach]
作者: c_c_lai    時間: 2013-12-6 20:56

回復 13# Hsieh
回復 16# ML089
回復 11# stillfish00
[attach]16985[/attach]
感謝各位的幫忙，如還有更佳效益的解決方案，
敬請不吝指教！
作者: c_c_lai    時間: 2013-12-7 08:04

本帖最後由 c_c_lai 於 2013-12-7 08:05 編輯

回復 16# ML089
以常理來論， 10 與 25 應無彼此間之串聯，應屬不同之區塊才是，
你在實作上是如何解析的？
作者: c_c_lai    時間: 2013-12-7 08:19

回復 16# ML089
Hsieh 版大他是應用 "遞迴" 的處理技巧，來求出各歸屬區塊的範圍，
這種點及於面的運用是個蠻不錯的 Idea，你看看程式碼細細地去推敲，
是蠻值得回味的， 在裏頭我加上了 sRng 的位址紀錄處理，並同時求取
每個區塊的實際位址數，以提供參考之用：
  1. Option Explicit

  3. Public s As Long
  4. Public sRng As Variant

  6. Sub ex()
  7.     Dim dic As Object
  8.     Dim A As Range, Rng As Range, sPos As Range
  9.    
  10.     Set dic = CreateObject("Scripting.Dictionary")
  11.     dic("連續數量") = "數量"
  12.     '   增列部分
  13.     工作表2.[C1] = "連續位址"
  14.     工作表2.[D1] = "組合數量"
  15.    
  16.     With 工作表1
  17.         Set Rng = .Range("A1").CurrentRegion
  18.         Rng.Replace 0, Empty, xlWhole
  19.         
  20.         Set sPos = 工作表2.[C2]
  21.         Set A = Rng.Find(Empty)
  22.         
  23.         Do Until A Is Nothing
  24.             A = 0: s = 1
  25.             Cnt A
  26.             dic(s) = dic(s) + 1
  27.             
  28.             sPos = sRng
  29.             sPos.Offset(0, 1) = Range(sRng).Count
  30.             
  31.             Set A = Rng.Find(Empty)
  32.             
  33.             Set sPos = sPos.Offset(1)
  34.         Loop
  35.     End With
  36.    
  37.     With 工作表2
  38.         .[A1].Resize(dic.Count, 1) = Application.Transpose(dic.keys)
  39.         .[B1].Resize(dic.Count, 1) = Application.Transpose(dic.items)
  40.         .[A1].Resize(dic.Count, 2).Sort key1:=.[A1], Header:=xlYes
  41.     End With
  42.    
  43.     '  MsgBox dic.Count - 1
  44.     Set dic = Nothing
  45. End Sub

  47. Function Cnt(Rng As Range)
  48.     Dim A As Range, Temp As Range
  49.     Dim i As Integer
  50.         
  51.     For Each A In Rng
  52.         For i = -1 To 1 Step 2
  53.             If A.Row + i > 0 And A.Row + i < 工作表1.Range("A1").CurrentRegion.Rows.Count Then
  54.                 If IsEmpty(A.Offset(i, 0)) Then Set Temp = Union(Rng, A.Offset(i, 0))   '  "$BF$4:$BF$5"
  55.             End If
  56.         Next
  57.         For i = -1 To 1 Step 2
  58.             If A.Column + i > 0 And A.Column + i < 工作表1.Range("A1").CurrentRegion.Columns.Count Then
  59.                 If IsEmpty(A.Offset(, i)) Then Set Temp = Union(Rng, A.Offset(, i))   '  "$BF$4:$BG$4"
  60.             End If
  61.         Next
  62.     Next

  64.     If Not Temp Is Nothing Then      '  True
  65.         Temp = 0
  66.         s = Temp.Count
  67.         sRng = Temp.Address
  68.         Cnt Temp
  69.     End If
  70. End Function
複製代碼
作者: c_c_lai    時間: 2013-12-7 08:40

本帖最後由 c_c_lai 於 2013-12-7 08:42 編輯

回復 20# c_c_lai
20# 的 Ex() 內之 C、D 欄一行一行地去遞增是為了要
觀察資料處理及過程。以下為改以 "字典" 處裡：
  1. Sub ex2()
  2.     Dim dic As Object, dic2 As Object
  3.     Dim A As Range, Rng As Range
  4.    
  5.     Set dic = CreateObject("Scripting.Dictionary")
  6.     Set dic2 = CreateObject("Scripting.Dictionary")
  7.     dic("連續數量") = "數量"
  8.     dic2("連續位址") = "組合數量"
  9.    
  10.     With 工作表1
  11.         Set Rng = .Range("A1").CurrentRegion
  12.         Rng.Replace 0, Empty, xlWhole
  13.         
  14.         Set A = Rng.Find(Empty)
  15.         
  16.         Do Until A Is Nothing
  17.             A = 0: s = 1
  18.             Cnt A
  19.             dic(s) = dic(s) + 1
  20.             dic2(sRng) = Range(sRng).Count
  21.             
  22.             Set A = Rng.Find(Empty)
  23.         Loop
  24.     End With
  25.    
  26.     With 工作表2
  27.         .[A1].Resize(dic.Count, 1) = Application.Transpose(dic.keys)
  28.         .[B1].Resize(dic.Count, 1) = Application.Transpose(dic.items)
  29.         .[A1].Resize(dic.Count, 2).Sort key1:=.[A1], Header:=xlYes
  30.         .[C1].Resize(dic2.Count, 1) = Application.Transpose(dic2.keys)
  31.         .[D1].Resize(dic2.Count, 1) = Application.Transpose(dic2.items)
  32.    End With
  33.    
  34.     '  MsgBox dic.Count - 1
  35.     Set dic = Nothing
  36.     Set dic2 = Nothing
  37. End Sub
複製代碼
感謝 Hsieh 版大的指導！
作者: ML089    時間: 2013-12-7 13:32

回復 19# c_c_lai
回復 13# Hsieh
回復 4# stillfish00

我做3個標準圖型及統計數量以供大家測試用
我的程式也採用遞迴呼叫方式處理，原圖形執行時間大概2~3秒就能完成。
這程式寫得很慢很久，每個指令都是從網路上或參考大家的程式慢慢堆出來的，一共花了7~8小時才完成，也滿有成就感，請有語法待改進之處請大家多多指教。
下方為測試檔案
[attach]16993[/attach]
   
[attach]16994[/attach]
作者: ML089    時間: 2013-12-7 13:37

回復 22# ML089
Timer使用的怪怪的，有時瞬間執行完成卻顯示9.X秒，Timer及TimeE計算出來也差很多(1.5秒及1.0秒)，幾乎差1.5倍，大家可以幫我看看嗎?
作者: ML089    時間: 2013-12-7 13:55

回復 22# ML089

這是DEBUD對話框輸入1時，可以產生陣列處理後的資料以供查核

    [attach]16995[/attach]
作者: c_c_lai    時間: 2013-12-7 15:19

回復 23# ML089
請教：
  1.     '  ↓ 計算每組個數。 注意! Frequency 回傳 i + 1 組，所先將 i - 1
  2.     Bins_array = Application.Evaluate("Row(1:" & i - 1 & ")")
  3.     ArrN = Application.Frequency(Arr, Bins_array)
  4.     MaxN = Application.Max(ArrN)

  6.     '  ↓ 統計每組個數。 注意! Frequency 回傳 i + 1 組，所先將 MaxN - 1
  7.     Bins_array = Application.Evaluate("Row(1:" & MaxN - 1 & ")")
  8.     ArrF = Application.Frequency(ArrN, Bins_array)
複製代碼
Bins_array、ArrN 、MaxN 、ArrF  的內涵及作用，能否加以解析，
我對一些用語不很孰悉，且反應較遲鈍，謝謝囉！
作者: stillfish00    時間: 2013-12-7 16:00

本帖最後由 stillfish00 於 2013-12-7 16:05 編輯

回復 22# ML089
Nice Job，提取到Array加速很多，
我也發現我的方法邏輯上有問題，
另外，Time原本就只有到秒而已，時間亂跳是因為你把 inputbox 的時間也算了。
作者: ML089    時間: 2013-12-7 16:40

回復 26# stillfish00
哈哈，內行人一看就找出問題，我竟然怪timer函數怪怪的，感謝
作者: c_c_lai    時間: 2013-12-7 17:21

本帖最後由 c_c_lai 於 2013-12-7 17:22 編輯

回復 26# stillfish00
回復 27# ML089
的確！
提取到Array確實加速很多，同時也解決了遲緩的困擾。
謝謝你等的指教！
作者: ML089    時間: 2013-12-7 17:37

回復 25# c_c_lai

Frequency 可以按F1看看說明。(以前我一開始看也不懂，這是正常的，多做題目才能慢慢了解)

用舉例說明
例一:有一群數字 {1,2,3,4,5,6,7,8,9}，要求3個範圍各有多少數字 1~2、3~7、8~9，公式如下
=FREQUENCY({1,2,3,4,5,6,7,8,9},{2,7,9}) = {2;4;2;0}，最後0是指大於9之數


用舉例說明
例二:例如以#22程式中下面部分程式來說明
   '  ↓ 計算每組個數。 注意! Frequency 回傳 i + 1 組，所先將 i - 1
    Bins_array = Application.Evaluate("Row(1:" & i - 1 & ")")
    ArrN = Application.Frequency(Arr, Bins_array)
    MaxN = Application.Max(ArrN)

    '  ↓ 統計每組個數。 注意! Frequency 回傳 i + 1 組，所先將 MaxN - 1
    Bins_array = Application.Evaluate("Row(1:" & MaxN - 1 & ")")
    ArrF = Application.Frequency(ArrN, Bins_array)

說明
   '  ↓ 計算每組個數。
1. 將每組連續0進行序號編碼放在陣列中，陣列資料例如下
   Arr={1,1,.."X" ,2,.."X" ,3,3,.."X" ,4,4,.."X" ,5,5,5,.."X" ,6,.."X" ,7,.."X" ,8,8,.."X" ,9,9,9,.."X"}
2. 我想求 1有幾個，2有幾個....9有幾個，可以用下列公式
   ArrN = FREQUENCY(Arr,{1,2,3,4,5,6,7,8}) = {2;1;2;2;3;1;1;2;3}
   回傳值表示為 1有3個、2有1個、3有2個、4有2個、5有3個、6有1個、7有1個、8有2個、9有3個
3. MaxN = Max({2;1;2;2;3;1;1;2;3}) = 3，所有組數中最大個數為 3 (後面計算要用)
       

    '  ↓ 統計每組個數。
4. 上面已經計算出每組的個數陣列 ArrN 及最大個數 MaxN，要統計各個數有幾組，公式如下
   ArrF = FREQUENCY(ArrN,{1,2,...,MaxN-1}) = {{2;1;2;2;3;1;1;2;3},{1,2}) = {3;4;2}       
   回傳值表示為 1個有3組、2個有4組、3個有2組

5. 公式中 Bins_array = Application.Evaluate("Row(1:" & i - 1 & ")") 就是要產生 {1,2,...i-1} 序號


6. 其他說明就要靠 GOOGLE 來查詢，多看幾個網頁說明就能明白，我也是一邊查一邊TRY才成功的。

剛接觸VBA功力尚淺，說明不清之處尚且見諒。
作者: ML089    時間: 2013-12-7 17:46

回復 28# c_c_lai

修正計時方式錯誤，將 INPUTBOX() 移至最前面，哇! 1秒多就能完成。
[attach]16998[/attach]
作者: c_c_lai    時間: 2013-12-7 17:53

回復 29# ML089
謝謝你詳盡的說明，剛才我已全部使用 Debug 跑了一圈，
不明瞭處亦已由Debug中得到答案，此程式應用陣列處理
亦排除了原先執行速度遲緩的困擾，謝謝你的幫忙！
作者: ML089    時間: 2013-12-7 20:07

回復 31# c_c_lai

昨天是用儲存格方式處理，大致需要3分鐘，早上改為陣列處理約需要10秒鐘，再進行優化可達2∼3秒鐘
可見儲存格與陣列處理速度相差20倍以上
作者: c_c_lai    時間: 2013-12-7 20:41

回復 32# ML089
試試經修改後之程式：
[attach]17000[/attach]
[attach]17001[/attach]
作者: c_c_lai    時間: 2013-12-7 20:45

回復 32# ML089
更正圖片，上頭的是在 Debug Mode， 所以時間較長，
更正後之圖片為確實執行秒數。
[attach]17002[/attach]
作者: c_c_lai    時間: 2013-12-7 20:50

本帖最後由 c_c_lai 於 2013-12-7 20:51 編輯

回復 32# ML089
增修後之程式碼如下：
  1. Option Explicit

  3. '  ML089 寫於 2013/12/7
  4. '  http://forum.twbts.com/viewthread.php?tid=10927&extra=&page=3
  5. Sub 連續0個數之統計()
  6.     Dim dic As Object
  7.     Dim t1 As Date, tt1 As Date, t2 As Date, tt2 As Date
  8.     Dim Arr As Variant, xDebug As String, sRng As Range, WriteToRange As Range
  9.     Dim i As Integer, c As Long, r As Long, y As Integer, rN As Long, cN As Long
  10.     Dim Bins_array As Variant, ArrF As Variant, ArrN As Variant, MaxN As Double
  11.    
  12.     Application.Calculation = xlManual    '  關閉計算
  13.     Application.ScreenUpdating = False    '  關閉顯示

  15.     xDebug = InputBox("陣列計算資料寫出。填入 1 / 0 控制 :", "DeBug", 0) '  ◎陣列計算資料寫出。填入 1、Ture / 0、Flase 控制
  16.     If xDebug Then ActiveSheet.Copy after:=ActiveSheet    '  Test Use 1

  18.     t1 = Timer: tt1 = Time    '  秒數計時器
  19.     Set dic = CreateObject("Scripting.Dictionary")
  20.     dic("連續位址") = "組合數量"

  22.     '  ↓ 找 0，將每組連續 0 編不同序號
  23.     '  Arr : Variant/Variant(1 to 20, 1 to 26)
  24.     Arr = ActiveSheet.[A1].CurrentRegion    '  讀入陣列
  25.    
  26.     i = 0
  27.     rN = UBound(Arr, 1)     '  Y  Rows     20
  28.     cN = UBound(Arr, 2)     '  X  Columns  26
  29.    
  30.     For c = 1 To cN
  31.         For r = 1 To rN     '  此迴圈將陣列非0值改為文字型態
  32.             If Arr(r, c) <> 0 Then Arr(r, c) = "X" '  Empty 會被視為 0，"" 不會
  33.         Next
  34.     Next
  35.     For c = 1 To cN
  36.         For r = 1 To rN    '  此迴圈找 0
  37.             If Arr(r, c) = 0 Then
  38.                 i = i + 1
  39.                 Set sRng = Sheets("TEST2").Cells(r, c)
  40.                 Call xRep(Arr, r, c, i, sRng)
  41.                 dic(sRng.Address) = Range(sRng.Address).Count
  42.             End If
  43.         Next
  44.     Next

  46.     If xDebug Then [A1].Resize(rN, cN) = Arr    '  Test Use 2    ' i = 11

  48.     '  ↓ 計算每組個數。 注意! Frequency 回傳 i + 1 組，所先將 i - 1
  49.     Bins_array = Application.Evaluate("Row(1:" & i - 1 & ")")   ' i = 11
  50.     '  計算某一個範圍內的值出現的次數，並傳回一個垂直數值陣列。
  51.     '  例如，用 FREQUENCY 來計算某些範圍內的考試成績各有幾個人。
  52.     '  由於 FREQUENCY 傳回陣列，因此必須輸入為陣列公式。
  53.     ArrN = Application.Frequency(Arr, Bins_array)
  54.     MaxN = Application.Max(ArrN)   '  MaxN : 62 : Variant/Double  (以上統計數的最大值)

  56.     '  ↓ 統計每組個數。 注意! Frequency 回傳 i + 1 組，所先將 MaxN - 1
  57.     Bins_array = Application.Evaluate("Row(1:" & MaxN - 1 & ")")
  58.     ArrF = Application.Frequency(ArrN, Bins_array)

  60.     '  ↓ 寫出資料
  61.     Set WriteToRange = ActiveSheet.Cells(rN + 3, 1)
  62.     WriteToRange.CurrentRegion.ClearContents
  63.     Application.Goto Reference:=WriteToRange, scroll:=True   ' 將畫面切換至 WriteToRange。
  64.     With WriteToRange
  65.         .Resize([A:A].Rows.Count - rN - 3, 2) = ""
  66.         .Resize(1, 2) = Application.Evaluate("{""連續數"", "";組數""}")
  67.         y = 0
  68.         For i = 1 To MaxN
  69.             If ArrF(i, 1) <> 0 Then
  70.                 y = y + 1
  71.                 .Offset(y, 0) = i
  72.                 .Offset(y, 1) = ArrF(i, 1)
  73.             End If
  74.         Next
  75.         .Offset(0, 2).Resize(dic.Count, 1) = Application.Transpose(dic.keys)
  76.         .Offset(0, 3).Resize(dic.Count, 1) = Application.Transpose(dic.items)
  77.          
  78.         t2 = Timer: .Offset(y + 1, 1) = Format(t2 - t1, "0.00") & " 秒"
  79.         tt2 = Time: .Offset(y + 2, 1) = Format((tt2 - tt1) * 24 * 60 * 60, "0.00") & " 秒"
  80.     End With
  81.     Set Arr = Nothing       '  釋放記憶體
  82.     Set dic = Nothing
  83.    
  84.     Application.ScreenUpdating = True
  85.     Application.Calculation = xlCalculationAutomatic
  86. End Sub

  88. '  遞迴呼叫( recursive call )查詢，將連續0寫入同一編號
  89. Sub xRep(ByRef Arr, r, c, i, ByRef rng As Range)
  90.     Dim Temp As Range
  91.    
  92.     Arr(r, c) = i    '  寫入編號
  93.     Cells(r, c).Interior.ColorIndex = 6    '  Test Use 3
  94.     Set Temp = Union(rng, Sheets("TEST2").Cells(r, c))
  95.     On Error Resume Next    '  避免邊界錯誤
  96.     If Arr(r - 1, c) = 0 Then Call xRep(Arr, r - 1, c, i, Temp)    '  找上
  97.     If Arr(r + 1, c) = 0 Then Call xRep(Arr, r + 1, c, i, Temp)    '  找下
  98.     If Arr(r, c - 1) = 0 Then Call xRep(Arr, r, c - 1, i, Temp)    '  找左
  99.     If Arr(r, c + 1) = 0 Then Call xRep(Arr, r, c + 1, i, Temp)    '  找右
  100.     Set rng = Temp
  101. End Sub
複製代碼




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