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
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
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
發表於 2016-10-20 13:53
| 
發表於 2016-10-21 19:50
| 
