12
返回列表 上一主題 發帖

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

GBKEE

帖子
5923 
主題
13 
精華
1 
積分
5986 
點名
0  
作業系統
win10 
軟體版本
Office 2010 
閱讀權限
150 
性別
男 
來自
台灣基隆 
註冊時間
2010-5-1 
最後登錄
2022-1-23 

2017 雞年全勤獎章2016猴年全勤獎章2015羊年全勤獎章2014馬年全勤獎章2013蛇年全勤獎章2012龍年全勤獎章論壇貢獻勳章熱烈參與勳章2011兔年全勤獎章
5# 跳轉到 »
發表於 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
複製代碼
感恩的心......(在麻辣家族討論區.用心學習會有進步的)
但資源無限,後援有限,  一天1元的贊助,人人有能力.

TOP

Hsieh

帖子
4901 
主題
44 
精華
24 
積分
4916 
點名
142  
作業系統
Windows 7 
軟體版本
Office 20xx 
閱讀權限
150 
性別
男 
來自
台北 
註冊時間
2010-4-30 
最後登錄
2026-7-16 

2025年全勤獎章2024年全勤獎章2023年全勤獎章2022虎年全勤獎章2021牛年全勤獎章2020鼠年全勤獎章2019 豬年全勤獎章2018 狗年全勤獎章2017 雞年全勤獎章2016猴年全勤獎章2015羊年全勤獎章2014馬年全勤獎章2013蛇年全勤獎章2012龍年全勤獎章論壇貢獻勳章熱心公益勳章2011兔年全勤獎章
4#
發表於 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
複製代碼
學海無涯_不恥下問

TOP

greetingsfromtw

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

論壇贊助勳章
3#
發表於 2016-10-20 16:50 | 只看該作者
回復 2# 准提部林

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

TOP

准提部林

帖子
2848 
主題
10 
精華
0 
積分
2903 
點名
0  
作業系統
〔略〕 
軟體版本
〔略〕 
閱讀權限
100 
性別
男 
來自
〔略〕 
註冊時間
2013-5-13 
最後登錄
2026-7-25 
2#
發表於 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)

  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也可)

TOP

        靜思自在 : 一個人的快樂．不是因為他擁有得多，而是因為他計較得少。
12
返回列表 上一主題