標題: [字典物件]單一欄位的值與多個陣列比對後並分類至不同欄位 [打印本頁]

---

作者: greetingsfromtw    時間: 2016-10-20 13:53     標題: [字典物件]單一欄位的值與多個陣列比對後並分類至不同欄位

各位前輩好,
小弟之前有在網上找到一個程式碼,
參考網址如下:
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)
則程式會出現錯誤,小弟實在不知該如何解決.

第二個問題是,
若原始資料內的值完全沒有符合陣列值任一字串的話,也會出現錯誤.

附上小弟修改後的程式碼及附件如下:

[attach]25586[/attach]

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

複製代碼

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

---

作者: 准提部林    時間: 2016-10-20 16:41

本帖最後由 准提部林 於 2016-10-20 16:43 編輯

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    時間: 2016-10-20 16:50

回復 2# 准提部林

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

---

作者: Hsieh    時間: 2016-10-20 23:38

回復 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    時間: 2016-10-21 08:06

回復 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    時間: 2016-10-21 10:44

回復 4# Hsieh

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

---

作者: starbox520    時間: 2016-10-21 10:52

回復 4# Hsieh


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

---

作者: greetingsfromtw    時間: 2016-10-21 11:00

回復 5# GBKEE

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

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

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

---

作者: 准提部林    時間: 2016-10-21 15:49

回復 8# greetingsfromtw


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

[attach]25594[/attach]
　
　

---

作者: greetingsfromtw    時間: 2016-10-21 19:42

回復 9# 准提部林

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

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

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

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

---

作者: 准提部林    時間: 2016-10-21 19:50

本帖最後由 准提部林 於 2016-10-21 19:53 編輯

回復 10# greetingsfromtw


那是工作表〔事件〕觸發程式，按Alt + F11，對工作表物件按兩下

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
Dim xR As Range
With Target
　　If Intersect([J2:L8], .Cells) Is Nothing Then Exit Sub
　　If .Value = "" Then Exit Sub
　　Cancel = True
　　For Each xR In Range([A2], Cells(Rows.Count, 1).End(xlUp))
　　　　If InStr(UCase(xR), UCase(.Value)) > 0 Then
　　　　　Cells(Rows.Count, "G").End(xlUp)(2) = xR
　　　　End If
　　Next
End With
End Sub

---

作者: greetingsfromtw    時間: 2016-10-21 19:53

回復 11# 准提部林



了解,有看到了,是寫在工作表內,不好意思,小弟再研究一下.感謝前輩提醒.

---

作者: Andy2483    時間: 2023-5-10 14:51

回復 9# 准提部林


    謝謝論壇,謝謝前輩
後學藉此帖學習前輩的方案1,方案學習心得註解如下,請前輩再指導

執行前:
[attach]36332[/attach]

執行結果:
[attach]36333[/attach]


Sub ex()
[B2:E200].ClearContents
'↑清除結果欄舊資料
Set d = CreateObject("Scripting.Dictionary")
'↑令d變數是字典
Set Rng = Range("J1").CurrentRegion.SpecialCells(xlCellTypeConstants)
'↑令Rng變數是 [J1]串並聯儲存格擴展範圍的非空白格  ('比對陣列)
For Each a In Range([A2], [A2].End(xlDown))
'↑設逐項迴圈!令a變數是A欄裡的儲存格 ('原始資料迴圈)
  For Each c In Rng
  '↑設逐項迴圈!令c變數是Rng變數裡的儲存格
     If InStr(UCase(a), UCase(c)) > 0 Then
     '↑如果a變數儲存格值轉換成英文大寫的新字串後,
     '裡面有包含 c變數儲存格值轉換成英文大寫的新字串
        d(c.Column) = ""
        '↑令以c變數欄位數當key,item是空字元,納入d字典裡
        '('記住比對到陣列的欄位)
     End If
  Next
  If d.Count > 0 Then
  '↑如果d字典key數量>0 ?('表示原始資料比對成功)
     For Each ky In d.keys
     '↑設逐項迴圈!令ky是d字典裡的一個key
       Cells(65536, ky - 8).End(xlUp).Offset(1, 0) = a
       '↑令結果欄的第一個空白格是 a變數(儲存格值)
     Next
     d.RemoveAll
     '↑清空d字典
     Else
     Cells(65536, "E").End(xlUp).Offset(1, 0) = a
     '↑比對不成功!就將a變數(儲存格值)放在E欄第一個空白格
  End If
Next
End Sub

---

作者: Andy2483    時間: 2023-5-10 15:42

回復 9# 准提部林


    謝謝前輩
後學藉此帖學習前輩方案2(不重複),方案學習心得註解如下,請前輩再指導

執行結果:
[attach]36334[/attach]


Sub U_Test()
Dim xR As Range, xD, Arr, Brr, Mx&, N%, G(1 To 4), DK
'↑宣告變數
[B2:E200].ClearContents
'↑清除結果欄舊資料
Arr = Range([A2], Cells(Rows.Count, 1).End(xlUp))
'↑令Arr變數是二維陣列,以A欄儲存格值(原始資料)帶入陣列裡
Set xD = CreateObject("Scripting.Dictionary")
'↑令xD變數是字典
For Each xR In [J2:L40]
'↑令設逐項迴圈!令xR是範圍儲存格裡的一格
    If xR <> "" Then xD(UCase(xR)) = xR.Column - 9
    '↑如果xR變數不是空的!就令其轉換為大寫英文當key,item是其欄數-9,
    '納入xD字典裡('關鍵字依其欄位帶序號)
Next
ReDim Brr(1 To UBound(Arr), 1 To 4)
'↑宣告Brr變數是二維空陣列,縱向範圍同Arr,橫向從1 到4
For i = 1 To UBound(Arr)
'↑設順迴圈
    N = 4
    '↑令N變數是 4 ('預設序號為4,是用來放不符合的資料)
    For Each DK In xD.keys
    '↑設逐項迴圈!令DK是xD字典裡的一個key
        If InStr(UCase(Arr(i, 1)), DK) Then N = xD(DK): Exit For
        '↑如果原始資料轉換英文大寫的新字串裡有包含DK變數!
        '就令N變數變更為 以DK變數查xD字典的item值('有符合,取出序號),
        '取出序號後就結束迴圈,代表不重複使用 原始資料
    Next
    G(N) = G(N) + 1
    '↑依序號不同, 各自在G這一維陣列裡 累計欄位的筆數
    If G(N) > Mx Then Mx = G(N)
    '↑取得最大筆數
    Brr(G(N), N) = Arr(i, 1)
    '↑按序號及筆數填入資料到陣列
Next i
[B2].Resize(Mx, 4) = Brr
'↑令從[B2]開始擴展有資料的列數4欄,以Brr陣列值帶入
End Sub

---

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