准提部林

回復 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

回復 11# 准提部林



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

Andy2483

回復 9# 准提部林


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

執行前:

下載 (98.49 KB)

2023-5-10 14:48

執行結果:

下載 (115.09 KB)

2023-5-10 14:49

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

回復 9# 准提部林


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

執行結果:

下載 (115.33 KB)

2023-5-10 15:39

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