vba資料搜尋比對,找出符合的數量

公式靈活性高，難在抓出準確的計算範圍，減少不必要的計算，

VBA若也是使用函數，且逐格或逐行寫入，在資料多下，也是不夠快，
尚且修改任一數據，皆必須重新執行一次；

所以，看需求及資料多寡再決定公式或VBA～～

2015-07-29 12:30:46 補充：
Sheet3
Ｂ１．輸入4　　Ｃ１，輸入6　　設格式為：0”字元”

Ｂ２：右拉下刷
=SUMPRODUCT(N(COUNTIF(OFFSET(Sheet1!$B$1,MATCH($A2,Sheet1!$A:$A,)-1,,COUNTIF(Sheet1!$A:$A,$A2),99),Sheet2!$A$1:$A$25)*(LEN(Sheet2!$A$1:$A$25)=B$1)))

用多一點的資料試試看～～
也是僅供參考，不答題！

2015-07-29 14:18:18 補充：
Sub TEST()
Dim R, xD, T$, U$, N&, V%, Arr, Brr
[Sheet3!2:60000].ClearContents
Set xD = CreateObject("Scripting.Dictionary")
For Each R In [Sheet2!A1:A25].Value: xD(R) = 1: Next

2015-07-29 14:18:40 補充：
Arr = Sheets("Sheet1").UsedRange
ReDim Brr(1 To UBound(Arr), 1 To 3)
For j = 1 To UBound(Arr)
　　T = Arr(j, 1)
　　If T <> "" And T <> U Then N = N + 1: U = T: Brr(N, 1) = U

2015-07-29 14:18:48 補充：
For k = 2 To UBound(Arr, 2)
　　T = Arr(j, k): V = Len(T)
　　If V = 4 Or V = 6 Then Brr(N, V / 2) = Brr(N, V / 2) + xD(T)
Next k
Next j
[Sheet3!A2:C2].Resize(N) = Brr
End Sub

2015-07-29 14:19:58 補充：
參考即可～～
Sheet1，一萬列應也幾秒可完成～～

2015-07-31 22:54:55 補充：
００７～００９程式碼，尚未知是否符合題需？

那些程式對還不熟VBA的，可能有點難度，要講解也不易，
DIC字典檔及ARRAY陣列，以前我也是摸一大陣子才稍會運用，
還有多天，不急著結案，等看看有否其他大大較平易的解法！

VBA重點在提問者能了解，並可依不同需求自己能修改，
這才是主要目的～～

2015-08-01 18:01:49 補充：
EXCEL VBA． 統計各項目明細符合條件的個數
　　　　　　　　　　　　　　　　　　　　　　　　　＜．准提部林．＞
－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－
■明細資料：z12263426372639343734393739263437z12010501100124051005241024010510z13010501300128053005393039010530z130105012801200130052805200530z131120202820272037112811271137z14012815383738　　　　z14012810191519101519　　　z14012820313031203031　　　　
■比對條件：01280524010530　　　
■輸出結果：　4個字元6個字元z1211z1322z1430
　
■程式碼：
Sub TEST()
Dim R, xD, T$, U$, N&, V%, Arr, Brr
[Sheet3!2:60000].ClearContents
　
Set xD = CreateObject("Scripting.Dictionary")
For Each R In [Sheet2!A1:A25].Value: xD(R) = 1: Next
　
Arr = Sheets("Sheet1").UsedRange
ReDim Brr(1 To UBound(Arr), 1 To 3)
　
For j = 1 To UBound(Arr)
　　T = Arr(j, 1)
　　If T <> "" And T <> U Then N = N + 1: U = T: Brr(N, 1) = U
　
　　For k = 2 To UBound(Arr, 2)
　　　　T = Arr(j, k): V = Len(T)
　　　　If V = 4 Or V = 6 Then Brr(N, V / 2) = Brr(N, V / 2) + xD(T)
　　Next k
Next j
[Sheet3!A2:C2].Resize(N) = Brr
End Sub
－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－
＜範例檔＞下載：
檔案名稱：20150801a01(統計各項目符合個數)
下載連結：http://www.funp.net/140107
－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－

2015-08-01 18:08:27 補充：
趁空貼答，看來應該沒人再有興趣參與此題！

〔監看功能〕，學VBA至今，從未用過，也不會用！^ ^
所以寫程式都以〔段式〕寫法，可逐段測試！

http://blog.xuite.net/hcm19522/twblog/329499642
參考即可

這裡的假設是只有sheet3的列一有文字分別為A1:編號, B1:4個字元, B3:6個字元
而列二開始都沒有資料,也抱括A2~An都沒有資料

2015-07-31 19:29:43 補充：
感謝准大指導...非常受用...不過,即然是正確好用的意見...准大仍不上答嗎, 若無法答題,此題恐會移除, 可惜了准大的意見~~

2015-08-01 11:24:31 補充：
謝謝准大的再次提點, 有試著以監看功能了解其陣列的變化,
雖了解不深, 但至少已初步的了解其方式,

而 ００７～００９程式碼,在此准大謙虛了,您提供的程式碼是完全符合題意所需.

2015-08-02 17:39:41 補充：
TO E大, 謝謝您的意見, 函數的部分也是要努力學習的地方, 待將答案稍作消化後,
再向您請教不明白之處,謝謝~~

TO 准大, 我已找出xD(T)變化的原因了, 謝謝您!!

只是統計個數用COUNTIF就可以
=COUNTIF(工作表1!$A:$A,工作表2!A1)

2015-07-29 12:12:58 補充：
Sub test()
Set rag = Sheets(1).[A:A]
sha = Sheets(2).[A65536].End(xlUp).Row
For i = 1 To sha
xr = Sheets(2).Cells(i, 1)
Sheets(3).Cells(i, 1) = Application.CountIf(rag, xr)
Next
End Sub

2015-07-29 12:14:43 補充：
Sheets(1)跟(2)對調一下
大概參考一下