[字典物件]單一欄位的值與多個陣列比對後並分類至不同欄位
- 帖子
- 45
- 主題
- 10
- 精華
- 0
- 積分
- 59
- 點名
- 0
- 作業系統
- Win7
- 軟體版本
- Office 2007
- 閱讀權限
- 20
- 性別
- 男
- 註冊時間
- 2014-2-6
- 最後登錄
- 2019-6-22
|
[字典物件]單一欄位的值與多個陣列比對後並分類至不同欄位
各位前輩好,
小弟之前有在網上找到一個程式碼,
參考網址如下:
http://club.excelhome.net/thread-868892-1-1.htmlz
其中的實例4,
可將一欄內的值使用InStr去比對多個陣列的值,
假設字串有符合,可分類至不同欄位.
現在遇到的第一個問題是,
該程式碼是將陣列的值寫在程式之中,類似這樣:
brr1 = Array("ASUS", "Sony")
但這在實作上是不太可能這樣去運用的,通常會想要將儲存格內的值寫入陣列中,
而非一個一個手動打在程式碼內.
可是,若想將儲存格的值存至陣列中,類似這樣:
brr1 = Range("j2:j" & Cells(Rows.Count, 10).End(xlUp).Row)
則程式會出現錯誤,小弟實在不知該如何解決.
第二個問題是,
若原始資料內的值完全沒有符合陣列值任一字串的話,也會出現錯誤.
附上小弟修改後的程式碼及附件如下:
 20161020_問題-比對單行資料與多個陣列.zip (11.13 KB)
- Sub test1()
- '參考網址:http://club.excelhome.net/thread-868892-1-1.htmlz
- '實例4
- Dim arr, myD1, myD2, myD3
- arr = Range("a2:a" & Cells(Rows.Count, 1).End(xlUp).Row)
- '若使用以下方式將儲存格對應至陣列則會出問題
- 'brr1 = Range("j2:j" & Cells(Rows.Count, 10).End(xlUp).Row)
- 'brr2 = Range("k2:k" & Cells(Rows.Count, 11).End(xlUp).Row)
- 'brr3 = Range("L2:L" & Cells(Rows.Count, 12).End(xlUp).Row)
- brr1 = Array("ASUS", "Sony")
- brr2 = Array("Samsung")
- brr3 = Array("長江", "小米")
- Set myD1 = CreateObject("Scripting.Dictionary")
- Set myD2 = CreateObject("Scripting.Dictionary")
- Set myD3 = CreateObject("Scripting.Dictionary")
- Set myD4 = CreateObject("Scripting.Dictionary")
- For x = 1 To UBound(arr)
- For i = 0 To UBound(brr1)
- If InStr(arr(x, 1), brr1(i)) > 0 Then
- myD1(arr(x, 1)) = ""
- GoTo 100
- End If
- Next i
- For j = 0 To UBound(brr2)
- If InStr(arr(x, 1), brr2(j)) > 0 Then
- myD2(arr(x, 1)) = ""
- GoTo 100
- End If
- Next j
- For k = 0 To UBound(brr3)
- If InStr(arr(x, 1), brr3(k)) > 0 Then
- myD3(arr(x, 1)) = ""
- GoTo 100
- End If
- Next k
- myD4(arr(x, 1)) = ""
- 100:
- Next x
- Range("b2").Resize(UBound(myD1.keys) + 1, 1) = Application.Transpose(myD1.keys)
- Range("c2").Resize(UBound(myD2.keys) + 1, 1) = Application.Transpose(myD2.keys)
- Range("d2").Resize(UBound(myD3.keys) + 1, 1) = Application.Transpose(myD3.keys)
- Range("e2").Resize(UBound(myD4.keys) + 1, 1) = Application.Transpose(myD4.keys)
- End Sub
|
|
|
|
|
|
|
|
- 帖子
- 2834
- 主題
- 10
- 精華
- 0
- 積分
- 2890
- 點名
- 0
- 作業系統
- 〔略〕
- 軟體版本
- 〔略〕
- 閱讀權限
- 100
- 性別
- 男
- 來自
- 〔略〕
- 註冊時間
- 2013-5-13
- 最後登錄
- 2024-11-22
|
2#
發表於 2016-10-20 16:41
| 只看該作者
本帖最後由 准提部林 於 2016-10-20 16:43 編輯
- Sub U_Test()
- Dim xR As Range, xD, Arr, Brr, Mx&, N%, G(1 To 4), DK
- Arr = Range([A2], Cells(Rows.Count, 1).End(xlUp))
- Set xD = CreateObject("Scripting.Dictionary")
- For Each xR In [J2:L40]
- If xR <> "" Then xD(UCase(xR)) = xR.Column - 9 '關鍵字依其欄位帶序號
- Next
- ReDim Brr(1 To UBound(Arr), 1 To 4)
- For i = 1 To UBound(Arr)
- N = 4 '預設序號為4
- For Each DK In xD.keys
- If InStr(UCase(Arr(i, 1)), DK) Then N = xD(DK): Exit For '有符合,取出序號
- Next
- G(N) = G(N) + 1 '依序號不同, 各自累計欄位的筆數
- If G(N) > Mx Then Mx = G(N) '取得最大筆數
- Brr(G(N), N) = Arr(i, 1) '按序號及筆數填入資料到陣列
- Next i
- [B2].Resize(Mx, 4) = Brr
- End Sub
InStr 會區分英文大小寫, 必須使用 UCase 統一轉為大寫(LCase也可) |
|
|
|
|
|
|
|
- 帖子
- 45
- 主題
- 10
- 精華
- 0
- 積分
- 59
- 點名
- 0
- 作業系統
- Win7
- 軟體版本
- Office 2007
- 閱讀權限
- 20
- 性別
- 男
- 註冊時間
- 2014-2-6
- 最後登錄
- 2019-6-22
|
3#
發表於 2016-10-20 16:50
| 只看該作者
回復 2# 准提部林
非常感謝淮提部林前輩提供解答,比原本的程式碼縮減很多,小弟嘆服.
目前還在努力鑽研字典物件中,
一定努力學習,
希望有朝一日能及得上前輩的萬分之一. |
|
|
|
|
|
|
|
- 帖子
- 5923
- 主題
- 13
- 精華
- 1
- 積分
- 5986
- 點名
- 0
- 作業系統
- win10
- 軟體版本
- Office 2010
- 閱讀權限
- 150
- 性別
- 男
- 來自
- 台灣基隆
- 註冊時間
- 2010-5-1
- 最後登錄
- 2022-1-23
        
|
5#
發表於 2016-10-21 08:06
| 只看該作者
回復 3# greetingsfromtw
不用字典物件也可以試試看- Option Explicit
- Sub Ex()
- Dim Rng As Range, R As Range, E As Range, i(1 To 2) As Integer
- With Range("J1").CurrentRegion
- i(1) = .Columns.Count + 1
- Set Rng = .Rows("2:" & .Rows.Count).SpecialCells(xlCellTypeConstants) '比對字串
- End With
- Range([A2], [A2].End(xlDown)).Offset(, 1).Resize(, i(1)) = ""
- For Each R In Range([A2], [A2].End(xlDown)) '原始資料迴圈
- i(2) = i(1)
- For Each E In Rng
- If InStr(UCase(R), UCase(E)) Then
- i(2) = E.Column - Range("J1").Column + 1
- Exit For
- End If
- Next
- With Cells(65536, 1 + i(2))
- If .EntireColumn.Find(R, Lookat:=xlPart) Is Nothing Then .End(xlUp).Offset(1) = R
- '資料不重複
- End With
- Next
- End Sub
|
|
|
|
|
|
|
|
- 帖子
- 45
- 主題
- 10
- 精華
- 0
- 積分
- 59
- 點名
- 0
- 作業系統
- Win7
- 軟體版本
- Office 2007
- 閱讀權限
- 20
- 性別
- 男
- 註冊時間
- 2014-2-6
- 最後登錄
- 2019-6-22
|
6#
發表於 2016-10-21 10:44
| 只看該作者
回復 4# Hsieh
非常感謝Hsieh前輩特地提供字典物件的另類解法,
也是將原程式碼縮減一大部份,令人佩服.
此論壇真是高手雲集,小弟一定努力學習. |
|
|
|
|
|
|
|
- 帖子
- 192
- 主題
- 15
- 精華
- 0
- 積分
- 194
- 點名
- 0
- 作業系統
- windows
- 軟體版本
- office2010
- 閱讀權限
- 20
- 性別
- 女
- 註冊時間
- 2016-9-22
- 最後登錄
- 2020-8-28
|
7#
發表於 2016-10-21 10:52
| 只看該作者
回復 4# Hsieh
比對的話可以用在ListBox裡面嗎
等於我反白裡面其中1項資訊
讓他對應後去做篩選
這是可行的嗎 |
|
|
|
|
|
|
|
- 帖子
- 45
- 主題
- 10
- 精華
- 0
- 積分
- 59
- 點名
- 0
- 作業系統
- Win7
- 軟體版本
- Office 2007
- 閱讀權限
- 20
- 性別
- 男
- 註冊時間
- 2014-2-6
- 最後登錄
- 2019-6-22
|
8#
發表於 2016-10-21 11:00
| 只看該作者
回復 5# GBKEE
非常感謝GBKEE前輩願意用其他方式來提供此問題的解法,
原始的程式碼較為冗長,
但三位前輩均輕描淡寫地用少量程式碼寫出漂亮解答,
此論壇實在是臥虎藏龍,有許多excel高手前輩俠隱於此,
而且還願意無私指點像新手,小弟銘感五內.
讚賞之言說得過多也擔心有浮誇之嫌,
小弟收入不是太多,所以可能沒辦法持續贊助高額費用,
但願意以"少額贊助"與"努力學習",
來分擔站長大人維護此論壇的設備費用與回應板上前輩們無私指點的恩德.
再次感謝. |
|
|
|
|
|
|
|
- 帖子
- 2834
- 主題
- 10
- 精華
- 0
- 積分
- 2890
- 點名
- 0
- 作業系統
- 〔略〕
- 軟體版本
- 〔略〕
- 閱讀權限
- 100
- 性別
- 男
- 來自
- 〔略〕
- 註冊時間
- 2013-5-13
- 最後登錄
- 2024-11-22
|
9#
發表於 2016-10-21 15:49
| 只看該作者
回復 8# greetingsfromtw
１．能贊助即可貴，這也幫助他人可以在此獲得知識
２．４樓超板的方法也許較符實情（以篩選而言），同一文字包含兩個關鍵字時，則兩次分別取出，
可測試範例檔的兩個程式去比較
３．另提供一個方便針對選取單一關鍵字的篩選法
 20161020_比對單行資料與多個陣列v01.rar (14.18 KB)
|
|
|
|
|
|
|
|
- 帖子
- 45
- 主題
- 10
- 精華
- 0
- 積分
- 59
- 點名
- 0
- 作業系統
- Win7
- 軟體版本
- Office 2007
- 閱讀權限
- 20
- 性別
- 男
- 註冊時間
- 2014-2-6
- 最後登錄
- 2019-6-22
|
10#
發表於 2016-10-21 19:42
| 只看該作者
回復 9# 准提部林
非常謝謝淮提部林前輩的回應.
雖然本身貢獻的不是很多,就是希望能夠對論壇有些微幫助.
小弟有將三位前輩的方式都有稍微測試,說真的,雖然小弟逛過的相關論壇很少,
但前輩們的程式碼和我在其他地方看到的寫法可說是完全不同.相當驚人,值得研究.
因目前本身的VBA程度太差,所以現在可能是試著模仿前輩的寫法,
先去寫一些基本的功能這樣,雖然是笨方法,不過起步總是痛苦的.
只能說光用看的跟自己寫是完全兩回事阿....還得再努力.
另外也十分感謝前輩所提供的附檔,
滑鼠點兩下直接篩選的這個功能實在太猛了,前所未見,
小弟斗膽,不知是否方便麻煩前輩指點是怎麼做到的?
好像不是寫在巨集中,也沒有使用儲存格公式. |
|
|
|
|
|
|
|
