[字典物件]單一欄位的值與多個陣列比對後並分類至不同欄位

greetingsfromtw

各位前輩好,
小弟之前有在網上找到一個程式碼,
參考網址如下:
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)

下載次數: 31

2016-10-20 13:51

1. Sub test1()
   
2. '參考網址:http://club.excelhome.net/thread-868892-1-1.htmlz
   
3. '實例4
   
4. 
   
5. 
   
6. Dim arr, myD1, myD2, myD3
   
7. arr = Range("a2:a" & Cells(Rows.Count, 1).End(xlUp).Row)
   
8. 
   
9. '若使用以下方式將儲存格對應至陣列則會出問題
   
10. 'brr1 = Range("j2:j" & Cells(Rows.Count, 10).End(xlUp).Row)
    
11. 'brr2 = Range("k2:k" & Cells(Rows.Count, 11).End(xlUp).Row)
    
12. 'brr3 = Range("L2:L" & Cells(Rows.Count, 12).End(xlUp).Row)
    
13. 
    
14. 
    
15. brr1 = Array("ASUS", "Sony")
    
16. brr2 = Array("Samsung")
    
17. brr3 = Array("長江", "小米")
    
18. 
    
19. Set myD1 = CreateObject("Scripting.Dictionary")
    
20. Set myD2 = CreateObject("Scripting.Dictionary")
    
21. Set myD3 = CreateObject("Scripting.Dictionary")
    
22. Set myD4 = CreateObject("Scripting.Dictionary")
    
23. 
    
24. For x = 1 To UBound(arr)
    
25. 
    
26. For i = 0 To UBound(brr1)
    
27. If InStr(arr(x, 1), brr1(i)) > 0 Then
    
28. myD1(arr(x, 1)) = ""
    
29. GoTo 100
    
30. End If
    
31. Next i
    
32. 
    
33. For j = 0 To UBound(brr2)
    
34. If InStr(arr(x, 1), brr2(j)) > 0 Then
    
35. myD2(arr(x, 1)) = ""
    
36. GoTo 100
    
37. End If
    
38. Next j
    
39. 
    
40. 
    
41. For k = 0 To UBound(brr3)
    
42. If InStr(arr(x, 1), brr3(k)) > 0 Then
    
43. myD3(arr(x, 1)) = ""
    
44. GoTo 100
    
45. End If
    
46. Next k
    
47. 
    
48. myD4(arr(x, 1)) = ""
    
49. 
    
50. 100:
    
51. Next x
    
52. 
    
53. 
    
54. Range("b2").Resize(UBound(myD1.keys) + 1, 1) = Application.Transpose(myD1.keys)
    
55. Range("c2").Resize(UBound(myD2.keys) + 1, 1) = Application.Transpose(myD2.keys)
    
56. Range("d2").Resize(UBound(myD3.keys) + 1, 1) = Application.Transpose(myD3.keys)
    
57. Range("e2").Resize(UBound(myD4.keys) + 1, 1) = Application.Transpose(myD4.keys)
    
58. 
    
59. 
    
60. End Sub

複製代碼

若可以的話希望前輩能夠不吝指點迷津,十分感謝.

准提部林

1. Sub U_Test()
   
2. Dim xR As Range, xD, Arr, Brr, Mx&, N%, G(1 To 4), DK
   
3. Arr = Range([A2], Cells(Rows.Count, 1).End(xlUp))
   
4. Set xD = CreateObject("Scripting.Dictionary")
   
5. For Each xR In [J2:L40]
   
6.     If xR <> "" Then xD(UCase(xR)) = xR.Column - 9 '關鍵字依其欄位帶序號
   
7. Next
   
8. ReDim Brr(1 To UBound(Arr), 1 To 4)
   
9. 
   
10. For i = 1 To UBound(Arr)
    
11.     N = 4 '預設序號為4
    
12.     For Each DK In xD.keys
    
13.         If InStr(UCase(Arr(i, 1)), DK) Then N = xD(DK): Exit For '有符合,取出序號
    
14.     Next
    
15.     G(N) = G(N) + 1 '依序號不同, 各自累計欄位的筆數
    
16.     If G(N) > Mx Then Mx = G(N) '取得最大筆數
    
17.     Brr(G(N), N) = Arr(i, 1) '按序號及筆數填入資料到陣列
    
18. Next i
    
19. [B2].Resize(Mx, 4) = Brr
    
20. End Sub

複製代碼

InStr 會區分英文大小寫, 必須使用 UCase 統一轉為大寫(LCase也可)

greetingsfromtw

回復 2# 准提部林

非常感謝淮提部林前輩提供解答,比原本的程式碼縮減很多,小弟嘆服.
目前還在努力鑽研字典物件中,
一定努力學習,
希望有朝一日能及得上前輩的萬分之一.

Hsieh

回復 3# greetingsfromtw

1. Sub ex()
   
2. Set d = CreateObject("Scripting.Dictionary")
   
3. Set Rng = Range("J1").CurrentRegion.SpecialCells(xlCellTypeConstants) '比對陣列
   
4. For Each a In Range([A2], [A2].End(xlDown)) '原始資料迴圈
   
5.   For Each c In Rng
   
6.      If InStr(UCase(a), UCase(c)) > 0 Then
   
7.         d(c.Column) = "" '記住比對到陣列的欄位
   
8.      End If
   
9.   Next
   
10.   If d.Count > 0 Then '表示原始資料比對成功
    
11.      For Each ky In d.keys
    
12.        Cells(65536, ky - 8).End(xlUp).Offset(1, 0) = a
    
13.      Next
    
14.      d.RemoveAll '清空字典
    
15.      Else
    
16.      Cells(65536, "E").End(xlUp).Offset(1, 0) = a '比對不成功
    
17.   End If
    
18. Next
    
19. End Sub

複製代碼

GBKEE

回復 3# greetingsfromtw
不用字典物件也可以試試看

1. Option Explicit
   
2. Sub Ex()
   
3.     Dim Rng As Range, R As Range, E As Range, i(1 To 2) As Integer
   
4.     With Range("J1").CurrentRegion
   
5.         i(1) = .Columns.Count + 1
   
6.         Set Rng = .Rows("2:" & .Rows.Count).SpecialCells(xlCellTypeConstants)  '比對字串
   
7.     End With
   
8.     Range([A2], [A2].End(xlDown)).Offset(, 1).Resize(, i(1)) = ""
   
9.     For Each R In Range([A2], [A2].End(xlDown)) '原始資料迴圈
   
10.             i(2) = i(1)
    
11.             For Each E In Rng
    
12.                 If InStr(UCase(R), UCase(E)) Then
    
13.                     i(2) = E.Column - Range("J1").Column + 1
    
14.                     Exit For
    
15.                 End If
    
16.             Next
    
17.           With Cells(65536, 1 + i(2))
    
18.             If .EntireColumn.Find(R, Lookat:=xlPart) Is Nothing Then .End(xlUp).Offset(1) = R
    
19.             '資料不重複
    
20.           End With
    
21.     Next
    
22. End Sub

複製代碼

greetingsfromtw

回復 4# Hsieh

非常感謝Hsieh前輩特地提供字典物件的另類解法,
也是將原程式碼縮減一大部份,令人佩服.
此論壇真是高手雲集,小弟一定努力學習.

starbox520

回復 4# Hsieh


    比對的話可以用在ListBox裡面嗎
    等於我反白裡面其中1項資訊
    讓他對應後去做篩選
    這是可行的嗎

greetingsfromtw

回復 5# GBKEE

非常感謝GBKEE前輩願意用其他方式來提供此問題的解法,
原始的程式碼較為冗長,
但三位前輩均輕描淡寫地用少量程式碼寫出漂亮解答,
此論壇實在是臥虎藏龍,有許多excel高手前輩俠隱於此,
而且還願意無私指點像新手,小弟銘感五內.

讚賞之言說得過多也擔心有浮誇之嫌,

小弟收入不是太多,所以可能沒辦法持續贊助高額費用,
但願意以"少額贊助"與"努力學習",
來分擔站長大人維護此論壇的設備費用與回應板上前輩們無私指點的恩德.
再次感謝.

准提部林

回復 8# greetingsfromtw


１．能贊助即可貴，這也幫助他人可以在此獲得知識
２．４樓超板的方法也許較符實情（以篩選而言），同一文字包含兩個關鍵字時，則兩次分別取出，
　　可測試範例檔的兩個程式去比較
３．另提供一個方便針對選取單一關鍵字的篩選法

20161020_比對單行資料與多個陣列v01.rar (14.18 KB)

下載次數: 29

2016-10-21 15:48

　
　

greetingsfromtw

回復 9# 准提部林

非常謝謝淮提部林前輩的回應.

雖然本身貢獻的不是很多,就是希望能夠對論壇有些微幫助.
小弟有將三位前輩的方式都有稍微測試,說真的,雖然小弟逛過的相關論壇很少,
但前輩們的程式碼和我在其他地方看到的寫法可說是完全不同.相當驚人,值得研究.

因目前本身的VBA程度太差,所以現在可能是試著模仿前輩的寫法,
先去寫一些基本的功能這樣,雖然是笨方法,不過起步總是痛苦的.
只能說光用看的跟自己寫是完全兩回事阿....還得再努力.

另外也十分感謝前輩所提供的附檔,
滑鼠點兩下直接篩選的這個功能實在太猛了,前所未見,
小弟斗膽,不知是否方便麻煩前輩指點是怎麼做到的?
好像不是寫在巨集中,也沒有使用儲存格公式.