Board logo

標題: 請教陣列比對超過3個 [打印本頁]

作者: duck_simon    時間: 2023-3-5 20:09     標題: 請教陣列比對超過3個

請教先進高手  陣列比對超過3個 內有詳細說明
[attach]35893[/attach]感謝~~~:lol
作者: hcm19522    時間: 2023-3-6 09:58

https://blog.xuite.net/hcm19522/twblog/590748962
作者: Andy2483    時間: 2023-3-6 10:15

本帖最後由 Andy2483 於 2023-3-6 10:35 編輯

回復 1# duck_simon


    謝謝前輩發表此主題與範例
後學練習陣列與字典的解決方案如下,請參考

執行前:
[attach]35895[/attach]

執行結果:
[attach]35896[/attach]


Option Explicit
Sub TEST_1()
Dim Brr, xR As Range, i&, j&, N&, A, B, V, Y, Z
Set Y = CreateObject("Scripting.Dictionary")
Set Z = CreateObject("Scripting.Dictionary")
Brr = [A1:J12]: [A1:J12].Interior.ColorIndex = xlNone: [K20] = ""
For Each xR In [B20:F20]
   Z(xR & "") = xR.Interior.ColorIndex: V = "/" & xR & "/" & V
Next
For i = 4 To UBound(Brr)
   Set Y(i) = CreateObject("Scripting.Dictionary")
   For j = 2 To UBound(Brr, 2)
      If Val(Brr(i, j)) > 0 Then
         Set Y(i)(Brr(i, j) & "") = Cells(i, j)
      End If
   Next
Next
For Each A In Y.Keys
   For Each B In Y(A).Keys
      If InStr(V, "/" & B & "/") Then
         N = N + 1
         If N >= 3 Then [K20] = "X": Exit For
      End If
   Next
   If N >= 3 Then
      For Each B In Y(A).Keys
         Y(A)(B).Interior.ColorIndex = Z(B)
      Next
   End If
   N = 0
Next
Set Y = Nothing: Set Z = Nothing: Set Brr = Nothing
End Sub
'==================================
'每列濾重複數字
作者: Andy2483    時間: 2023-3-6 13:48

回復 3# Andy2483

藉此帖練習改為自訂函數

Bingo(資料格, 關鍵字格, 顯示字元,每列符合數量)
K15=Bingo(B4:J12,B20:F20,"X",3)
[attach]35897[/attach]

Option Explicit
Function Bingo(資料格 As Range, 關鍵字格 As Range, T$, S%)
Dim Brr, xR As Range, i&, j&, N&, A, B, V, Y
Application.Volatile
Set Y = CreateObject("Scripting.Dictionary")
Brr = 資料格
For Each xR In 關鍵字格
   V = "/" & xR & "/" & V
Next
For i = 1 To UBound(Brr)
   Set Y(i) = CreateObject("Scripting.Dictionary")
   For j = 1 To UBound(Brr, 2)
      If Val(Brr(i, j)) > 0 Then
         Set Y(i)(Brr(i, j) & "") = Cells(i, j)
      End If
   Next
Next
For Each A In Y.Keys
   For Each B In Y(A).Keys
      If InStr(V, "/" & B & "/") Then
         N = N + 1
         If N >= S Then
            Bingo = T
            Set Y = Nothing: Set Brr = Nothing
            Exit Function
         End If
      End If
   Next
   N = 0
Next
Bingo = ""
End Function
作者: duck_simon    時間: 2023-3-6 14:54

本帖最後由 duck_simon 於 2023-3-6 14:55 編輯

感謝二位前輩指導..我代入後..因為格不同產生#VALUE!
IF(OR(MMULT(COUNTIF($N18:$S18,$AV$3:$BH$14),ROW(3:14)^0)>2),"X","")
請教哪裡出問題? 因在下笨拙..是行列高度 嗎?   謝謝
作者: hcm19522    時間: 2023-3-6 15:35

回復 5# duck_simon

表格 手動改自動 :點上面 "公式"-->點右邊 "運算選項"-->點 "自動"
ROW(3:14)改ROW(1:13) 試試
排除N18:S18空格=IF(OR(MMULT(COUNTIF(N18:S18,AV3:BH14)*(AV3:BH14<>""),ROW(1:13)^0)>2),"X","")
作者: Andy2483    時間: 2023-3-7 08:36

回復 5# duck_simon


    今天修改複習了一下,請前輩參考

執行前:
[attach]35898[/attach]

執行結果:
[attach]35899[/attach]

Option Explicit
Sub TEST_1()
Dim Brr, A, B, V, Y, Z, xR As Range, i&, j&, N&
'↑宣告變數:(Brr,A,B,V,Y,Z)是通用型變數,xR是儲存格變數,(i,j,N)是長整數變數
Set Y = CreateObject("Scripting.Dictionary")
'↑令Y這通用型變數是字典
Set Z = CreateObject("Scripting.Dictionary")
'↑令Z這通用型變數是字典
Brr = [A1:BH14]
'↑令Brr這通用型變數是 二維陣列!以[A1:BH14]儲存格值帶入
[AV3:BH14].Interior.ColorIndex = xlNone
'↑令[AV3:BH14]儲存格底色是無色
[K20] = ""
'↑令[K20]儲存格值是空字元
For Each xR In [N18:S18]
'↑設迴圈令xR這儲存格變數是 [N18:S18]裡的一儲存格
   Z(xR & "") = xR.Interior.ColorIndex
   '↑令xR變數 連接空字元組合的字串當Key,Item是xR變數的底色,納入Z字典
   V = "/" & xR & "/" & V
   '↑令V這通用型變數是 "/" 連接 xR變數 再連接 "/" 最後連接 V變數自身
Next
For i = 3 To UBound(Brr)
'↑設順迴圈!i從3 到Brr陣列縱向最大索引列號
   Set Y(i) = CreateObject("Scripting.Dictionary")
   '↑令i變數當Key,Item是字典,納入Y字典裡
   For j = 22 To UBound(Brr, 2)
   '↑設順迴圈!j從22 到Brr陣列橫向最大索引欄號
      If Val(Brr(i, j)) > 0 Then
      '↑如果以Val()轉化 i列j欄的Brr陣列值大於0 ?
         Set Y(i)(Brr(i, j) & "") = Cells(i, j)
         '↑令i列j欄的Brr陣列值連接空字元的新字串當Key,
         'Item是i列j欄儲存格,納入i變數的Y字典

      End If
   Next
Next
For Each A In Y.Keys
'↑設外逐項迴圈!令A這通用型變數是Y字典的其中一個Key
   For Each B In Y(A).Keys
   '↑設內逐項迴圈!令B這通用型變數是A變數Y字典的其中一個Key
      If InStr(V, "/" & B & "/") Then
      '↑如果V變數裡有 包含(B變數前後連接 "/"的新字串)??
         N = N + 1
         '↑If條件成立就令N這長整數變數累加1
         If N >= 3 Then [K20] = "X": Exit For
         '↑如果N變數 >=3!就令[K20]儲存格值是"X"!然後跳出內迴圈
      End If
   Next
   If N >= 3 Then
   '↑如果N變數 >=3 ?
      For Each B In Y(A).Keys
      '↑設內逐項迴圈!令B變數是A變數Y字典的其中一個Key
         Y(A)(B).Interior.ColorIndex = Z(B)
         '↑令B變數查A變數Y字典的Item底色是 以B變數查Z字典回傳值
      Next
   End If
   N = 0
Next
Set Y = Nothing: Set Z = Nothing: Set Brr = Nothing
'↑令釋放變數
End Sub
作者: duck_simon    時間: 2023-3-7 09:10

回復 6# hcm19522

回hcm19522 大大:
N18:S18沒空格..且是數值無誤.試了一晚.找不到原因我嘗試使用輔助欄  或改為統計數字..謝謝先進!....
作者: duck_simon    時間: 2023-3-7 09:13

回復 7# Andy2483


    大大對于VB 非常深入..惟小的連毛都不懂..見笑了..我還是收藏.拿來用上.非常感謝!.
作者: hcm19522    時間: 2023-3-7 09:45

回復 8# duck_simon


    https://blog.xuite.net/hcm19522/twblog/590684229
作者: Andy2483    時間: 2023-3-7 10:40

本帖最後由 Andy2483 於 2023-3-7 10:52 編輯

回復 9# duck_simon


    #5樓範例與#1範例相同,是不是傳錯檔??無法更了解前輩的瓶頸在哪裡!
建議上傳更貼近需求的範例
作者: Andy2483    時間: 2023-3-7 10:51

回復 10# hcm19522


    謝謝前輩,公式很難學,摸索中

[attach]35902[/attach]
作者: duck_simon    時間: 2023-3-7 14:39

回復 10# hcm19522

感謝大大..先來研究一下.. 謝謝
作者: duck_simon    時間: 2023-3-7 15:00

回復 10# hcm19522


  報告大大:  成功出來了.  哈哈. 這句話有點   哈哈:) 怎麼成功的.我也不知道..萬分感謝
作者: duck_simon    時間: 2023-3-7 18:25

回復 10# hcm19522


雖然函式出來了..不出現#VALUE!  .. 但驗證結果還是有錯..
作者: duck_simon    時間: 2023-3-7 18:27

回復 12# Andy2483


謝謝大大解說..我慢慢研究中..可否請大大驗證?
作者: 准提部林    時間: 2023-3-7 22:39

本帖最後由 准提部林 於 2023-3-7 22:40 編輯

一樓附檔//只適用純數值
=IF(OR(MMULT(1-ISERROR(RANK(B4:J12,B20:F20)),ROW(B4:B12)^0)>2),"X","")

[attach]35903[/attach]
作者: duck_simon    時間: 2023-3-8 09:46

回復  duck_simon


    #5樓範例與#1範例相同,是不是傳錯檔??無法更了解前輩的瓶頸在哪裡!
建議上傳更 ...
Andy2483 發表於 2023-3-7 10:40



   是的..一個範例檔(壓縮)..一個是實際應用檔
作者: duck_simon    時間: 2023-3-8 10:03

一樓附檔//只適用純數值
=IF(OR(MMULT(1-ISERROR(RANK(B4:J12,B20:F20)),ROW(B4:B12)^0)>2),"X","")
准提部林 發表於 2023-3-7 22:39



   感謝提部林 先進..代入後產生#VALUE...
IF(OR(MMULT(1-ISERROR(RANK($BH$1:$BR$13,N18:S18)),ROW($2:$12)^0)>2),"X","")
後改成 ROW(B4:B12)=ROW(B2:B12)    也驗證成功
真是怪異..辛苦三位先進..
作者: Andy2483    時間: 2023-3-8 11:37

回復 18# duck_simon


    謝謝前輩回復
後學繼續學習VBA方案的心得如下,請前輩參考
[attach]35905[/attach]

執行結果:
[attach]35904[/attach]

Option Explicit
Sub TEST_2()
Call 亂數重置

Dim Brr, xR As Range, i&, j&, A, B, V, Y
Set Y = CreateObject("Scripting.Dictionary")
Brr = [A1:J12]: [A1:J12].Interior.ColorIndex = xlNone: [K20] = ""
For Each xR In [B20:F20]
   Y(xR & "/") = xR.Interior.ColorIndex: V = V & "/" & xR
Next
For i = 4 To UBound(Brr)
i01:
   For j = 2 To UBound(Brr, 2)
      If B = 1 Then
         Cells(i, j).Interior.ColorIndex = Y(Cells(i, j) & "/")
         ElseIf InStr(V & "/", "/" & Brr(i, j) & "/") Then
            If Y("|") < 2 Then
               Y("|") = Y("|") + 1
               Else
                  B = 1: [K20] = "X": GoTo i01
            End If
      End If
   Next
   Y("|") = 0: B = 0
Next
Set Y = Nothing: Set Brr = Nothing
End Sub

Sub 亂數重置()
With [B4:J12]
   .Value = "=INT(MOD(RAND()*1000,49))+1"
   .Value = .Value
End With
End Sub
作者: 准提部林    時間: 2023-3-8 12:20

回復 19# duck_simon


=IF(OR(MMULT(1-ISERROR(RANK(B4:J12,B20:F20)),ROW($1:$9)^0)>2),"X","")

B~J欄共9欄...對應Row(1:9)..9行
作者: Andy2483    時間: 2023-3-8 14:24

回復 20# Andy2483


    以下是濾重複後比對超過3個的VBA方法,請各位前輩指導

Option Explicit
Sub TEST_2()
Call 亂數重置

Dim Brr, xR As Range, i&, j&, A, B, V, Y
Set Y = CreateObject("Scripting.Dictionary")
Brr = [A1:J12]: [A1:J12].Interior.ColorIndex = xlNone: [K20] = ""
For Each xR In [B20:F20]
   Y(xR & "/") = xR.Interior.ColorIndex: V = V & "/" & xR
Next
For i = 4 To UBound(Brr)
i01:
   For j = 2 To UBound(Brr, 2)
      If B = 1 Then
         Cells(i, j).Interior.ColorIndex = Y(Cells(i, j) & "/")
         ElseIf InStr(V & "/", "/" & Brr(i, j) & "/") And Y(Brr(i, j) & "/" & i) = "" Then
            If Y("|") < 2 Then
               Y("|") = Y("|") + 1
               Else
                  B = 1: [K20] = "X": GoTo i01
            End If
            Y(Brr(i, j) & "/" & i) = 1
      End If
   Next
   Y("|") = 0: B = 0
Next
Set Y = Nothing: Set Brr = Nothing
End Sub
作者: Andy2483    時間: 2023-3-8 15:47

回復 22# Andy2483


    謝謝論壇,謝謝各位前輩
後學延伸學習,不使用字典濾重複的方案,請各位前輩指導

Option Explicit
Sub TEST_2()
Call 亂數重置

Dim Brr, xR As Range, i&, j&, A(49), B, V
Brr = [A1:J12]: [A1:J12].Interior.ColorIndex = xlNone: [K20] = ""
For Each xR In [B20:F20]
   A(Val(xR)) = xR.Interior.ColorIndex: V = V & "/" & xR
Next
For i = 4 To UBound(Brr)
i01: A(0) = "||"
   For j = 2 To UBound(Brr, 2)
      If B = 1 Then
         Cells(i, j).Interior.ColorIndex = A(Cells(i, j))
         ElseIf InStr(V & "/", "/" & Brr(i, j) & "/") And InStr(A(0), "/" & Brr(i, j) & "/") = 0 Then
            If Val(A(0)) < 2 Then
               A(0) = Val(A(0)) + 1 & "|" & Mid(A(0), 3)
               Else
                  B = 1: [K20] = "X": GoTo i01
            End If
            A(0) = A(0) & "/" & Brr(i, j) & "/"
      End If
   Next
   B = 0
Next
Set Brr = Nothing: Erase A
End Sub
作者: duck_simon    時間: 2023-3-8 22:48

回復  duck_simon


=IF(OR(MMULT(1-ISERROR(RANK(B4:J12,B20:F20)),ROW($19)^0)>2),"X","")

B~J欄 ...
准提部林 發表於 2023-3-8 12:20



感謝大大  了解  辛苦了!
作者: duck_simon    時間: 2023-3-8 22:49

回復  Andy2483


    謝謝論壇,謝謝各位前輩
後學延伸學習,不使用字典濾重複的方案,請各位前輩指導
...
Andy2483 發表於 2023-3-8 15:47



    收藏了  將來用上    謝謝!
作者: Andy2483    時間: 2023-3-9 09:05

回復 25# duck_simon


    謝謝論壇,謝謝各位前輩
再次謝謝前輩發表此主題與範例
後學複習昨天的習題心得註解如下,請參考
試按了幾百次最多4個比對上,沒偏財運

Option Explicit
Sub TEST_2()
Call 亂數重置
'↑執行(亂數重置)副程式

Dim Brr, B, V, Y, xR As Range, i&, j&
'↑宣告變數:(Brr,B,V,Y)是通用型變數,xR是儲存格變數,(i,j)是長整數變數
Set Y = CreateObject("Scripting.Dictionary")
'↑令Y這通用型變數是 字典
Brr = [A1:J12]: [A1:J12].Interior.ColorIndex = xlNone: [K20] = ""
'↑令Brr這通用型變數是 二維陣列!以[A1:J12]儲存格值倒入,
'令[A1:J12]儲存格底色是 無色 :[K20]儲存格值是空字元

For Each xR In [B20:F20]
'↑設逐項迴圈!令xR這儲存格變數是 [B20:F20]儲存格的一格
   Y(xR & "/") = xR.Interior.ColorIndex: V = V & "/" & xR
   '↑令xR變數連接 "/"的新字串為Key,Item是 xR變數的底色 納入Y字典,
   '令V這通用型變數是 自身連接 "/"再連接 xR變數的新字串

Next
For i = 4 To UBound(Brr)
'↑設順迴圈!i從4 到Brr陣列縱向最大索引列號
i01:
   For j = 2 To UBound(Brr, 2)
   '↑設順迴圈!j從2 到Brr陣列橫向最大索引欄號
      If B = 1 Then
      '↑如果B這通用型變數是 1??
         Cells(i, j).Interior.ColorIndex = Y(Cells(i, j) & "/")
         '↑令i迴圈列j迴圈欄的儲存格底色是:
         '以i迴圈列j迴圈欄的儲存格值連接"/"的新字串為Key查Y字典的回傳值

         ElseIf InStr(V & "/", "/" & Brr(i, j) & "/") Then
         '↑否則如果V變數連接 "/"的新字串裡包含了,
         '包含了(i迴圈列j迴圈欄Brr陣列值在前後各連接"/"的新字串)

            If Y("|") < 2 Then
            '↑如果以 "|"查Y字典回傳Item值 < 2 ?
               Y("|") = Y("|") + 1
               '↑令Y字典裡"|"為key的item值累加 1
               Else
                  B = 1: [K20] = "X": GoTo i01
                  '↑令B變數是 1:令[K20]儲存格值是 "X",
                  '最後跳到 i01標示位置繼續執行

            End If
      End If
   Next
   Y("|") = 0: B = 0
   '↑令Y字典裡"|"為key的item值是 0:令B變數是 0
Next
Set Y = Nothing: Set Brr = Nothing
'↑令釋放變數
End Sub
========================================
Sub 亂數重置()
With [B4:J12]
'↑以下是關於[B4:J12]儲存格的程序
   .Value = "=INT(MOD(RAND()*1000,49))+1"
   '↑令格值是公式:
   '0到1之間的亂數1000倍除以49的餘數去除小數後 +1

   .Value = .Value
   '↑令格裡的公式轉化為值
End With
End Sub
========================================
Option Explicit
Sub TEST_2_字典濾重複()
Call 亂數重置
'↑令執行(亂數重置)副程式

Dim Brr, B, V, Y, xR As Range, i&, j&
'↑宣告變數:(Brr,B,V,Y)是通用型變數,xR是儲存存格變數,(i,j)是長整數變數
Set Y = CreateObject("Scripting.Dictionary")
'↑令Y這通用型變數是 字典
Brr = [A1:J12]: [A1:J12].Interior.ColorIndex = xlNone: [K20] = ""
'↑令Brr這通用型變數是 二維陣列!以[A1:J12]儲存格值帶入,
'令[A1:J12]儲存格底色是無色,令[K20]儲存格值是 空字元

For Each xR In [B20:F20]
'↑令設逐項迴圈!令xR這儲存格變數是 [B20:F20]儲存格裡的一格
   Y(xR & "/") = xR.Interior.ColorIndex: V = V & "/" & xR
   '↑令xR變數連接"/"的新字串當key,item是xR變數的底色納入Y字典,
   '令V這通用型變數是 自身連接"/"再連接xR變數的新字串

Next
For i = 4 To UBound(Brr)
'↑設順迴圈!i從4 到Brr陣列縱向最大索引列號
i01:
   For j = 2 To UBound(Brr, 2)
   '↑設順迴圈!j從2 到Brr陣列橫向最大索引欄號數
      If B = 1 Then
      '↑如果B這通用型變數是 1?
         Cells(i, j).Interior.ColorIndex = Y(Cells(i, j) & "/")
         '↑令i迴圈列j迴圈欄的儲存格底色是:
         '以i迴圈列j迴圈欄的儲存格值連接"/"的新字串為Key查Y字典的回傳值

         ElseIf InStr(V & "/", "/" & Brr(i, j) & "/") And Y(Brr(i, j) & "/" & i) = "" Then
         '↑否則如果V變數連接 "/"的新字串裡包含了,
         '包含了(i迴圈列j迴圈欄Brr陣列值在前後各連接"/"的新字串)
         '而且 i迴圈列j迴圈欄Brr陣列值連接"/"再連接i變數的新字串查Y字典回傳值是空字元?

            If Y("|") < 2 Then
            '↑如果以 "|"查Y字典回傳Item值 < 2 ?
               Y("|") = Y("|") + 1
               '↑令Y字典裡"|"為key的item值累加 1
               Else
                  B = 1: [K20] = "X": GoTo i01
                  '↑令B變數是 1:令[K20]儲存格值是 "X",
                  '最後跳到 i01標示位置繼續執行

            End If
            Y(Brr(i, j) & "/" & i) = 1
            '↑令i迴圈列j迴圈欄Brr陣列值連接"/"再連接i變數的新字串,
            '這新字串為Y字典key的item值是 1

      End If
   Next
   Y("|") = 0: B = 0
   '↑令Y字典裡"|"為key的item值是 0:令B變數是 0
Next
Set Y = Nothing: Set Brr = Nothing
'↑令釋放變數
End Sub
========================================
Option Explicit
Sub TEST_2_Instr濾重複()
Call 亂數重置
'↑令執行(亂數重置)副程式

Dim Brr, B, V, xR As Range, i&, j&, A(49)
'↑宣告變數:(Brr,B,V,)是通用型變數,xR是儲存存格變數,(i,j)是長整數變數,A是一維陣列(0~49)
Brr = [A1:J12]: [A1:J12].Interior.ColorIndex = xlNone: [K20] = ""
'↑令Brr這通用型變數是 二維陣列!以[A1:J12]儲存格值帶入,
'令[A1:J12]儲存格底色是無色,令[K20]儲存格值是 空字元

For Each xR In [B20:F20]
'↑令設逐項迴圈!令xR這儲存格變數是 [B20:F20]儲存格裡的一格
   A(Val(xR)) = xR.Interior.ColorIndex: V = V & "/" & xR
   '↑令xR變數轉化為數字為索引號的A陣列值是xR變數的底色號
   '令V這通用型變數是 自身連接"/"再連接xR變數的新字串

Next
For i = 4 To UBound(Brr)
'↑設順迴圈!i從4 到Brr陣列縱向最大索引列號
i01: A(0) = "||"
   For j = 2 To UBound(Brr, 2)
   '↑設順迴圈!j從2 到Brr陣列橫向最大索引欄號數
      If B = 1 Then
      '↑如果B這通用型變數是 1?
         Cells(i, j).Interior.ColorIndex = A(Cells(i, j))
         '↑令i迴圈列j迴圈欄的儲存格底色是:
         '以i迴圈列j迴圈欄的儲存格值為索引號的 A陣列值

         ElseIf InStr(V & "/", "/" & Brr(i, j) & "/") And InStr(A(0), "/" & Brr(i, j) & "/") = 0 Then
         '↑否則如果V變數連接 "/"的新字串裡包含了,
         '包含了(i迴圈列j迴圈欄Brr陣列值在前後各連接"/"的新字串)
         '而且 i迴圈列j迴圈欄Brr陣列值前後各連接"/"的新字串在 0索引號A陣列裡有被包含?

            If Val(A(0)) < 2 Then
            '↑如果0索引號A陣列值轉化為數值後 < 2?
               A(0) = Val(A(0)) + 1 & "|" & Mid(A(0), 3)
               '↑令0索引號A陣列值是 自身轉化為數值+1 連接"|" 再連接自身從第3字開始之後全部字串,
               '組合成的新字串

               Else
                  B = 1: [K20] = "X": GoTo i01
                  '↑令B變數是 1:令[K20]儲存格值是 "X",
                  '最後跳到 i01標示位置繼續執行

            End If
            A(0) = A(0) & "/" & Brr(i, j) & "/"
            '↑令0索引號A陣列值是 自身連接"/" 再連接i迴圈列j迴圈欄Brr陣列值,
            '最後連接"/"的新字串

      End If
   Next
   B = 0
   '↑令令B變數是 0
Next
Set Brr = Nothing: Erase A
'↑令釋放變數
End Sub




歡迎光臨 麻辣家族討論版版 (http://forum.twbts.com/)