標題:
[發問]
請教要如何使用 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 是代表第二工作表圖片 顏色的數字
敬請大家指教，謝謝！
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
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
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
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
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
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
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
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
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
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
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
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
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
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
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
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
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
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
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
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
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
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
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
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
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
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
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
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
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
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
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
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
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
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
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
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
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
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
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
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
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
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
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
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
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
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
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
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
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
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
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
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
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
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
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
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
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
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
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
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
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
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
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
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
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字典 : 面積 , 個數
依需求再自己改改吧
Sub test()
Dim d1, d2, bCombine As Boolean, lCol As Long
Dim stripe As Range, stripeOffset As Range, rngTarget As Range
Set d1 = CreateObject("scripting.dictionary")
With Sheets(1).[A1].CurrentRegion
.Replace What:="0", Replacement:=""
For lCol = 1 To .Columns.Count
If Application.CountA(.Columns(lCol).Cells) < .Columns(lCol).Cells.Count Then
For Each stripe In .Columns(lCol).SpecialCells(xlCellTypeBlanks).Areas
If stripe.Column = 1 Then
Set stripeOffset = stripe
Else
Set stripeOffset = .Parent.Range(stripe.Address).Offset(0, -1)
End If
bCombine = False
For Each prev In d1.keys
If Not Application.Intersect(.Parent.Range(prev), stripeOffset) Is Nothing Then
If d1.exists(stripe.Address) Then d1.Remove (stripe.Address)
Set stripe = Union(.Parent.Range(prev), stripe)
d1.Remove prev
d1(stripe.Address) = stripe.Count
Set stripeOffset = Union(stripeOffset, .Parent.Range(prev))
bCombine = True
End If
Next prev
If Not bCombine Then d1(stripe.Address) = stripe.Count
Next stripe
End If
Next lCol
.Replace What:="", Replacement:="0"
End With
Set d2 = CreateObject("scripting.dictionary")
For Each x In d1.items
If d2.exists(x) Then
d2(x) = d2(x) + 1
Else
d2(x) = 1
End If
Next
For Each x In d2.keys
Debug.Print "面積 " & x & " : " & d2(x) & "個"
Next
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
' Sheets(1).Columns(lCol).Cells.Count : 65536
' Sheets(1).Range(Chr(64 + lCol) & Sheets(1).Rows.Count).End(xlUp).Row : 960
' Application.CountA(.Columns(lCol).Cells) : 861
複製代碼
將處裡的範圍予以縮小，以避免耗時處裡：
' If Application.CountA(.Columns(lCol).Cells) < .Columns(lCol).Cells.Count Then
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
另外，
If Not Application.Intersect(.Parent.Range(prev), stripeOffset) Is Nothing Then
複製代碼
我將它改成
If Not Application.Intersect(Range(prev), stripeOffset) Is Nothing Then
複製代碼
不知對否？ 如此它才能判斷
' 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 的位址紀錄處理，並同時求取
每個區塊的實際位址數，以提供參考之用：
Option Explicit
Public s As Long
Public sRng As Variant
Sub ex()
Dim dic As Object
Dim A As Range, Rng As Range, sPos As Range
Set dic = CreateObject("Scripting.Dictionary")
dic("連續數量") = "數量"
' 增列部分
工作表2.[C1] = "連續位址"
工作表2.[D1] = "組合數量"
With 工作表1
Set Rng = .Range("A1").CurrentRegion
Rng.Replace 0, Empty, xlWhole
Set sPos = 工作表2.[C2]
Set A = Rng.Find(Empty)
Do Until A Is Nothing
A = 0: s = 1
Cnt A
dic(s) = dic(s) + 1
sPos = sRng
sPos.Offset(0, 1) = Range(sRng).Count
Set A = Rng.Find(Empty)
Set sPos = sPos.Offset(1)
Loop
End With
With 工作表2
.[A1].Resize(dic.Count, 1) = Application.Transpose(dic.keys)
.[B1].Resize(dic.Count, 1) = Application.Transpose(dic.items)
.[A1].Resize(dic.Count, 2).Sort key1:=.[A1], Header:=xlYes
End With
' MsgBox dic.Count - 1
Set dic = Nothing
End Sub
Function Cnt(Rng As Range)
Dim A As Range, Temp As Range
Dim i As Integer
For Each A In Rng
For i = -1 To 1 Step 2
If A.Row + i > 0 And A.Row + i < 工作表1.Range("A1").CurrentRegion.Rows.Count Then
If IsEmpty(A.Offset(i, 0)) Then Set Temp = Union(Rng, A.Offset(i, 0)) ' "$BF$4:$BF$5"
End If
Next
For i = -1 To 1 Step 2
If A.Column + i > 0 And A.Column + i < 工作表1.Range("A1").CurrentRegion.Columns.Count Then
If IsEmpty(A.Offset(, i)) Then Set Temp = Union(Rng, A.Offset(, i)) ' "$BF$4:$BG$4"
End If
Next
Next
If Not Temp Is Nothing Then ' True
Temp = 0
s = Temp.Count
sRng = Temp.Address
Cnt Temp
End If
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 欄一行一行地去遞增是為了要
觀察資料處理及過程。以下為改以 "字典" 處裡：
Sub ex2()
Dim dic As Object, dic2 As Object
Dim A As Range, Rng As Range
Set dic = CreateObject("Scripting.Dictionary")
Set dic2 = CreateObject("Scripting.Dictionary")
dic("連續數量") = "數量"
dic2("連續位址") = "組合數量"
With 工作表1
Set Rng = .Range("A1").CurrentRegion
Rng.Replace 0, Empty, xlWhole
Set A = Rng.Find(Empty)
Do Until A Is Nothing
A = 0: s = 1
Cnt A
dic(s) = dic(s) + 1
dic2(sRng) = Range(sRng).Count
Set A = Rng.Find(Empty)
Loop
End With
With 工作表2
.[A1].Resize(dic.Count, 1) = Application.Transpose(dic.keys)
.[B1].Resize(dic.Count, 1) = Application.Transpose(dic.items)
.[A1].Resize(dic.Count, 2).Sort key1:=.[A1], Header:=xlYes
.[C1].Resize(dic2.Count, 1) = Application.Transpose(dic2.keys)
.[D1].Resize(dic2.Count, 1) = Application.Transpose(dic2.items)
End With
' MsgBox dic.Count - 1
Set dic = Nothing
Set dic2 = Nothing
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
請教：
' ↓ 計算每組個數。 注意! 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)
複製代碼
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
增修後之程式碼如下：
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
複製代碼
歡迎光臨 麻辣家族討論版版 (http://forum.twbts.com/)
，結果如下