返回列表 上一主題 發帖

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

greetingsfromtw

帖子
45 
主題
10 
精華
0 
積分
59 
點名
0  
作業系統
Win7 
軟體版本
Office 2007 
閱讀權限
20 
性別
男 
註冊時間
2014-2-6 
最後登錄
2019-6-22 

論壇贊助勳章
1# 跳轉到 » 倒序看帖
打印
tT
發表於 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)
則程式會出現錯誤,小弟實在不知該如何解決.

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

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

20161020_問題-比對單行資料與多個陣列.zip (11.13 KB)
  1. Sub test1()
  2. '參考網址:http://club.excelhome.net/thread-868892-1-1.htmlz
  3. '實例4


  6. Dim arr, myD1, myD2, myD3
  7. arr = Range("a2:a" & Cells(Rows.Count, 1).End(xlUp).Row)

  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)


  15. brr1 = Array("ASUS", "Sony")
  16. brr2 = Array("Samsung")
  17. brr3 = Array("長江", "小米")

  19. Set myD1 = CreateObject("Scripting.Dictionary")
  20. Set myD2 = CreateObject("Scripting.Dictionary")
  21. Set myD3 = CreateObject("Scripting.Dictionary")
  22. Set myD4 = CreateObject("Scripting.Dictionary")

  24. For x = 1 To UBound(arr)

  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

  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


  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

  48. myD4(arr(x, 1)) = ""

  50. 100:
  51. Next x


  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)


  60. End Sub
複製代碼
若可以的話希望前輩能夠不吝指點迷津,十分感謝.
收藏 分享

greetingsfromtw

帖子
45 
主題
10 
精華
0 
積分
59 
點名
0  
作業系統
Win7 
軟體版本
Office 2007 
閱讀權限
20 
性別
男 
註冊時間
2014-2-6 
最後登錄
2019-6-22 

論壇贊助勳章
2#
發表於 2016-10-20 16:50 | 顯示全部帖子
回復 2# 准提部林

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

TOP

greetingsfromtw

帖子
45 
主題
10 
精華
0 
積分
59 
點名
0  
作業系統
Win7 
軟體版本
Office 2007 
閱讀權限
20 
性別
男 
註冊時間
2014-2-6 
最後登錄
2019-6-22 

論壇贊助勳章
3#
發表於 2016-10-21 10:44 | 顯示全部帖子
回復 4# Hsieh

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

TOP

greetingsfromtw

帖子
45 
主題
10 
精華
0 
積分
59 
點名
0  
作業系統
Win7 
軟體版本
Office 2007 
閱讀權限
20 
性別
男 
註冊時間
2014-2-6 
最後登錄
2019-6-22 

論壇贊助勳章
4#
發表於 2016-10-21 11:00 | 顯示全部帖子
回復 5# GBKEE

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

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

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

TOP

greetingsfromtw

帖子
45 
主題
10 
精華
0 
積分
59 
點名
0  
作業系統
Win7 
軟體版本
Office 2007 
閱讀權限
20 
性別
男 
註冊時間
2014-2-6 
最後登錄
2019-6-22 

論壇贊助勳章
5#
發表於 2016-10-21 19:42 | 顯示全部帖子
回復 9# 准提部林

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

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

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

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

TOP

greetingsfromtw

帖子
45 
主題
10 
精華
0 
積分
59 
點名
0  
作業系統
Win7 
軟體版本
Office 2007 
閱讀權限
20 
性別
男 
註冊時間
2014-2-6 
最後登錄
2019-6-22 

論壇贊助勳章
6#
發表於 2016-10-21 19:53 | 顯示全部帖子
回復 11# 准提部林



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

TOP

        靜思自在 : 布施如播種，以歡喜心滋潤種子，才會發芽。
返回列表 上一主題