[發問] 請問如何一个條件匹配多个結果(去重複)

hycn

請問一个条件匹配多个结果並去重複
這 VBA Function 函數要如何修改
因為E欄單元格條件匹配是希望去重複並有" , "符號隔開

在此先言謝 ~

一個條件匹配多個結果(去重複).rar (10.65 KB)

下載次數: 19

2020-11-8 09:54

hcm19522

https://blog.xuite.net/hcm19522/twblog/589452662

samwang

回復 1# hycn


    Sub test()
    Dim arr, 棋盤(1 To 2000, 1 To 2), i%
    Dim d As Object, d1 As Object
    Set d = CreateObject("scripting.dictionary")
    Set d1 = CreateObject("scripting.dictionary")
    arr = Range("b1", [a65536].End(xlUp))

    For i = 1 To UBound(arr)
        xR = arr(i, 1) & arr(i, 2)
        If d.Exists(arr(i, 1)) Then
            If d1.Exists(xR) Then GoTo 100
            列 = d(arr(i, 1))
            棋盤(列, 2) = 棋盤(列, 2) & "," & arr(i, 2)
        Else
            k = k + 1
            d(arr(i, 1)) = k
            棋盤(k, 1) = arr(i, 1)
            棋盤(k, 2) = arr(i, 2)
        End If
        d1(xR) = arr(i, 1) & arr(i, 2)
100:    Next
    Range("D1").Resize(k, 2) = 棋盤
End Sub

准提部林

回復 1# hycn

Function abc(a As Range, b As Range, c$) As String
Dim Ta$, Tb$, TT$
If a.Count <> b.Count Then abc = "error": Exit Function
If c = "" Then Exit Function
For i = 1 To a.Count
    Ta = a(i, 1):  Tb = b(i, 1)
    If Ta <> c Or Tb = "" Then GoTo 101
    If InStr("," & TT & ",", "," & Tb & ",") = 0 Then TT = TT & "," & Tb  '比對b文字是否已存在于TT字串中
101: Next
abc = Mid(TT, 2)
End Function

Andy2483

回復 4# 准提部林


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

執行結果:

下載 (45.06 KB)

2023-6-6 09:50

Function abc(a As Range, b As Range, c$) As String
'↑自訂函數abc().宣告變數:(a,b)是儲存格變數,c是字串變數,函數值是字串
Dim Ta$, Tb$, TT$
'↑宣告變數!(Ta,Tb,TT)是字串變數
If a.Count <> b.Count Then abc = "error": Exit Function
'↑如果a變數(儲存格)數量與 b變數(儲存格)數量不同?
'就令abc函數回傳"error"字串,然後結束程式執行
If c = "" Then Exit Function
'↑如果c變數是空字元?就結束程式執行
For i = 1 To a.Count
'↑設順迴圈!從1到 a變數(儲存格)數量
    Ta = a(i, 1):  Tb = b(i, 1)
    '↑令Ta變數是a變數(範圍儲存格)裡的i變數列,第1欄儲存格值,
    '↑令Tb變數是b變數(範圍儲存格)裡的i變數列,第1欄儲存格值
    If Ta <> c Or Tb = "" Then GoTo 101
    '↑如果Ta變數不等於C變數,或Tb變數是空字元,就跳到標示101位置繼續執行
    If InStr("," & TT & ",", "," & Tb & ",") = 0 Then TT = TT & "," & Tb
    '如果比對Tb變數文字沒有存在于TT變數字串中?
    '就令Tb變數以逗號隔開加在TT變數後方
101: Next
abc = Mid(TT, 2)
'↑令abc函數回傳TT變數擷取第2字後的所有字串(因為最前面是逗號,不取)
End Function

Andy2483

謝謝論壇,謝謝各位前輩
後學藉此帖練習陣列與字典,學習方案如下,請各位前輩指教


Option Explicit
Sub TEST()
Dim Brr, Crr, Y, i&, T1$, T2$
'↑宣告變數
Set Y = CreateObject("Scripting.Dictionary")
'↑令Y變數是 字典
Brr = Range([B2], [A65536].End(3))
'↑令Brr變數是二維陣列,以[B2]到A欄最後一有內容的儲存格值帶入
For i = 1 To UBound(Brr)
'↑設順迴圈
   T1 = Brr(i, 1): T2 = Brr(i, 2)
   '↑令變數裝入迴圈陣列值,可以定義值的型態,也可縮短程式碼
   If T1 = "" Or T2 = "" Then GoTo i01
   '↑如果T1變數是空的或 T1變數是空的?就跳到標示i01位置繼續執行
   If Y(T1) = "" Then Y(T1) = T2: GoTo i01
   '↑如果以T1變數查Y字典得item值是 空的?
   '是就令T1變數當key,item是T2變數,納入Y字典中,跳到標示i01位置繼續執行
   If InStr("," & Y(T1) & ",", "," & T2 & ",") = 0 Then
   '↑如果以T1變數提取Y字典中item值有沒有包含 T2變數?
   'InStr()中的元素都以逗號包夾後再判斷,降低巧合的意外機率
      Y(T1) = Y(T1) & "," & T2
      '↑令T1變數在Y字典中的item值連接T2變數,中間以逗號隔開
   End If
i01: Next
Brr = Range([D2], [D65536].End(3))
'↑令Brr變數是二維陣列,換裝[B2]到A欄最後一有內容的儲存格值
ReDim Crr(1 To UBound(Brr), 1 To 1)
'↑令Crr變數是 二維空陣列,縱向範圍同Brr陣列,橫向1~1
For i = 1 To UBound(Brr)
'↑設順迴圈
   Crr(i, 1) = Y(Brr(i, 1))
   '↑令Crr陣列值是 Brr陣列值查Y字典的item值
Next
[E2:E65536].ClearContents
'↑令儲存格舊結果清除
[E2].Resize(UBound(Crr)) = Crr
'↑令從[E2]儲存格開始寫入Crr陣列值
Set Y = Nothing: Erase Brr, Crr
'↑令釋放變數
End Sub