返回列表 上一主題 發帖

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

hycn

帖子
4 
主題
4 
精華
0 
積分
56 
點名
0  
作業系統
Window 
軟體版本
MS2010 
閱讀權限
20 
性別
女 
註冊時間
2019-5-30 
最後登錄
2020-11-8 
1# 跳轉到 » 倒序看帖
打印
tT
發表於 2020-11-8 09:54 | 只看該作者

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

本帖最後由 hycn 於 2020-11-8 09:58 編輯

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

在此先言謝 ~

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

hcm19522

帖子
1070 
主題
0 
精華
0 
積分
1076 
點名
0  
作業系統
WIN 
軟體版本
2007 
閱讀權限
50 
性別
男 
註冊時間
2015-9-11 
最後登錄
2021-1-19 

熱烈參與勳章
2#
發表於 2020-11-9 10:00 | 只看該作者
https://blog.xuite.net/hcm19522/twblog/589452662
隨意窩 "EXCEL迷"  blog  或 http://blog.xuite.net/hcm19522/twblog[img][/img]
已收集7000篇 EXCEL函數

TOP

samwang

帖子
141 
主題
7 
精華
0 
積分
184 
點名
0  
作業系統
Windows XP 
軟體版本
Office 2007 
閱讀權限
20 
性別
男 
註冊時間
2013-4-19 
最後登錄
2021-1-18 
3#
發表於 2020-11-9 14:08 | 只看該作者
回復 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

TOP

准提部林

帖子
2285 
主題
9 
精華
0 
積分
2341 
點名
0  
作業系統
〔略〕 
軟體版本
〔略〕 
閱讀權限
100 
性別
男 
來自
〔略〕 
註冊時間
2013-5-13 
最後登錄
2021-1-18 
4#
發表於 2020-11-9 16:32 | 只看該作者
回復 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

TOP

        靜思自在 : 信心、毅力、勇氣三者具備，則天下沒有做不成的事。
返回列表 上一主題