[發問] 如何自動選取相同的組合

donod

將B組與A組有相同的PT組合(PT1-PT8)選出來，再把B組相關的分數顯示在P欄，請教大大如何寫才能做到?謝謝!
TEST A.rar (8.41 KB)

下載次數: 18

2012-2-26 02:44

oobird

歡迎新同學！

1. Sub test()
   
2.     Dim d As Object, a As Range, b As Range, i%, x$
   
3.     Set d = CreateObject("Scripting.Dictionary")
   
4.     Set b = [r7:ac18]
   
5.     For i = 1 To b.Rows.Count
   
6.         x = Join(Application.Transpose(Application.Transpose(b(i, 5).Resize(, 8))), ",")
   
7.         d(x) = b(i, 1)
   
8.     Next
   
9.     Set a = [h7:o18]
   
10.     For i = 1 To a.Rows.Count
    
11.         x = Join(Application.Transpose(Application.Transpose(a(i, 1).Resize(, 8))), ",")
    
12.         If d.exists(x) Then a(i, 9).Value = d(x)
    
13.     Next
    
14. End Sub

複製代碼

donod

回復 2# oobird


    謝謝大大回覆!
實際工作時，有多個工作頁，可否每個工作頁加入多個"選擇範圍按鈕"，請問如何寫才可以?謝謝!
TEST A2.rar (10.11 KB)

下載次數: 8

2012-2-26 10:40

GBKEE

回復 3# donod
實際工作時，有多個工作頁
你舉的範例不是多個工作頁

donod

回復 4# GBKEE


    對不起!是我說不清楚!
是指會重複增開工作頁，而工作內容大約類同(範例用了相同內容)，都是各組配對A組。請教大大如何寫才做到。
TEST A3.rar (19.7 KB)

下載次數: 18

2012-2-26 12:20

GBKEE

回復 5# donod
請複製到ThisWorkbook模組內

1. 'ThisWorkbook 的預設事件
   
2. Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)
   
3.     Dim xX As Integer, Ar(), A As Range, B As Range, i As Integer, x As Variant
   
4.     With Sh
   
5.         If Target.Address(0, 0) = "P7" Then         '選擇了 P7
   
6.             Set B = .Range("T10:AE21")              '制訂 B 組(分數- PT8) 範圍
   
7.             xX = 0                                  ' P欄
   
8.         ElseIf Target.Address(0, 0) = "Q7" Then     '選擇了 Q7
   
9.             Set B = .Range("AH10:AS21")             '制訂 C組(分數-PT8) 範圍
   
10.             xX = 1                                  ' P欄 右移一欄 :Q欄
    
11.         ElseIf Target.Address(0, 0) = "R7" Then     '選擇了 R7
    
12.             Set B = .Range("AV10:BG21")             '制訂 D組(分數-PT8) 範圍
    
13.             xX = 2                                  ' P欄 右移二欄 :R欄
    
14.         Else
    
15.             Exit Sub                                 '離開程序
    
16.         End If
    
17.         Set A = .Range("H10:O21")                   '制訂 A 組(PT1-PT8) 範圍
    
18.         A.Interior.ColorIndex = xlNone              '清除A 組(PT1-PT8) 範圍圖樣
    
19.         B.Interior.ColorIndex = xlNone               '清除B ,C , D. 組 範圍圖樣
    
20.         ReDim Ar(1 To A.Rows.Count)                 '重新宣告 陣列的維數
    
21.         For i = 1 To B.Rows.Count                   '取得B,C,D,組的 (PT1-PT8) 的內容  置入陣列 Ar
    
22.             Ar(i) = Join(Application.Transpose(Application.Transpose(B(i, 5).Resize(, 8))), ",")
    
23.         Next
    
24.         For i = 1 To A.Rows.Count
    
25.             x = Join(Application.Transpose(Application.Transpose(A(i, 1).Resize(, 8))), ",")
    
26.             x = Application.Match(x, Ar, 0)         '工作表函數Match 在Ar尋找 相同字串
    
27.             A(i, 9 + xX) = ""                       '清除
    
28.             If Not IsError(x) Then                  '找到傳回數字
    
29.                 B(x, 5).Resize(, 8).Interior.ColorIndex = 6
    
30.                 A(i, 1).Resize(, 8).Interior.ColorIndex = 6
    
31.                 A(i, 9 + xX) = B(x, 1)               'B,C,D,組的分數
    
32.             End If
    
33.         Next
    
34.     End With
    
35. End Sub

複製代碼

donod

回復 6# GBKEE


    可以了!感謝大大細心講解!

donod

回復 6# GBKEE


   22.    Ar(i) = Join(Application.Transpose(Application.Transpose(B(i, 5).Resize(, 8))), ",")
請教大大以上公式是什麼意思?B(i, 5)是指哪些位置?謝謝!

GBKEE

回復 8# donod
如 Set  B=[B2]
B(2, 5) = B.Cells(2, 5) =B.Offset(1, 4) =[F3]
-> B.Cells(2, 5)  ->含B2 的位置    向下位移2列  :  向右位移5欄    =[F3]
-> B.Offset(1, 4)->不含B2 的位置  向下位移1列  :   向右位移4欄  =[F3]

donod

回復 9# GBKEE


    明白了，謝謝!