hycn

帖子: 4
主題: 4
精華: 0
積分: 56
點名: 0
作業系統: Window
軟體版本: MS2010
閱讀權限: 20
性別: 女
註冊時間: 2019-5-30
最後登錄: 2021-6-20

1^# 跳轉到 » 倒序看帖

打印

字體大小: tT

發表於 2020-11-8 09:54 | 只看該作者

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

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

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

在此先言謝 ~

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

樓主熱帖

hcm19522

大學生 Rank: 4

帖子: 1391
主題: 4
精華: 0
積分: 1401
點名: 0
作業系統: WIN
軟體版本: 2007
閱讀權限: 50
性別: 男
註冊時間: 2015-9-11
最後登錄: 2024-12-16

熱烈參與勳章

2^#

發表於 2020-11-9 10:00 | 只看該作者

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

google"EXCEL迷" blog 或google網址:https://hcm19522.blogspot.com/

TOP

samwang

大學生 Rank: 4

帖子: 976
主題: 7
精華: 0
積分: 1018
點名: 0
作業系統: Win10
軟體版本: Office 2016
閱讀權限: 50
性別: 男
註冊時間: 2013-4-19
最後登錄: 2024-12-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

准提部林

版主 Rank: 7 Rank: 7 Rank: 7

帖子: 2839
主題: 10
精華: 0
積分: 2895
點名: 0
作業系統: 〔略〕
軟體版本: 〔略〕
閱讀權限: 100
性別: 男
來自: 〔略〕
註冊時間: 2013-5-13
最後登錄: 2024-12-22

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

Andy2483

　暱稱: 厚臉皮的學生

大學生 Rank: 4

帖子: 1447
主題: 40
精華: 0
積分: 1471
點名: 0
作業系統: Windows 7
軟體版本: Excel 2010 & 2016
閱讀權限: 50
性別: 男
來自: 台灣
註冊時間: 2020-7-15
最後登錄: 2024-12-5

5^#

發表於 2023-6-6 09:51 | 只看該作者

回復 4# 准提部林

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

執行結果:

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

用行動裝置瀏覽論壇學習很方便,謝謝論壇經營團隊
請大家一起上論壇來交流

TOP

Andy2483

　暱稱: 厚臉皮的學生

大學生 Rank: 4

帖子: 1447
主題: 40
精華: 0
積分: 1471
點名: 0
作業系統: Windows 7
軟體版本: Excel 2010 & 2016
閱讀權限: 50
性別: 男
來自: 台灣
註冊時間: 2020-7-15
最後登錄: 2024-12-5

6^#

發表於 2023-6-6 11:07 | 只看該作者

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

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

用行動裝置瀏覽論壇學習很方便,謝謝論壇經營團隊
請大家一起上論壇來交流

TOP