Board logo

標題: [發問] 如何自動選取相同的組合 [打印本頁]
作者: donod    時間: 2012-2-26 02:49     標題: 如何自動選取相同的組合

將B組與A組有相同的PT組合(PT1-PT8)選出來，再把B組相關的分數顯示在P欄，請教大大如何寫才能做到?謝謝!
[attach]9755[/attach]
作者: oobird    時間: 2012-2-26 07:58

歡迎新同學！
  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    時間: 2012-2-26 10:42

本帖最後由 donod 於 2012-2-26 11:15 編輯

回復 2# oobird


    謝謝大大回覆!
實際工作時，有多個工作頁，可否每個工作頁加入多個"選擇範圍按鈕"，請問如何寫才可以?謝謝!
[attach]9758[/attach]
作者: GBKEE    時間: 2012-2-26 11:29

回復 3# donod
實際工作時，有多個工作頁
你舉的範例不是多個工作頁
作者: donod    時間: 2012-2-26 12:16

本帖最後由 donod 於 2012-2-26 12:26 編輯

回復 4# GBKEE


    對不起!是我說不清楚!
是指會重複增開工作頁，而工作內容大約類同(範例用了相同內容)，都是各組配對A組。請教大大如何寫才做到。
[attach]9761[/attach]
作者: GBKEE    時間: 2012-2-26 13:50

回復 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    時間: 2012-2-26 14:15

回復 6# GBKEE


    可以了!感謝大大細心講解!
作者: donod    時間: 2012-2-27 17:10

本帖最後由 donod 於 2012-2-27 17:13 編輯

回復 6# GBKEE


   22.    Ar(i) = Join(Application.Transpose(Application.Transpose(B(i, 5).Resize(, 8))), ",")
請教大大以上公式是什麼意思?B(i, 5)是指哪些位置?謝謝!
作者: GBKEE    時間: 2012-2-27 17:32

回復 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    時間: 2012-2-27 17:40

回復 9# GBKEE


    明白了，謝謝!
作者: donod    時間: 2012-2-28 00:41

回復 9# GBKEE


    請教大大，是什麼位置出錯?
[attach]9787[/attach]
作者: GBKEE    時間: 2012-2-28 10:46

回復 11# donod
Module1 中 的Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range) 是不會 有動作的
那是ThisWorkbook 的預設事件 那程序必須是在 ThisWorkbook中
你每一工作表的 B,C,D組的位置都不一樣 當然會不準確
需用每一工作表的預設事件 程序  Private Sub Worksheet_SelectionChange(ByVal Target As Range)
依每一工作表的 B,C,D組的位置 去設定
作者: donod    時間: 2012-2-28 13:44

回復 12# GBKEE


    改了，煩請大大看看是哪裡錯，謝謝!
[attach]9791[/attach]
作者: GBKEE    時間: 2012-2-28 14:48

回復 13# donod
用ThisWorkbook模組內   Private Sub Worksheet_SelectionChange(ByVal Target As Range)程序
是因為如 每一工作表有B,C,D 分組的 位置都一樣可用   Private Sub Workbook_SheetSelectionChange   不必每一工作表模組內去寫程序

現在因每一工作表B,C,D 分組的 位置都不一樣  所以啊
每一有B,C,D 分組的工作表模組內 都要一有個它適用的   Private Sub Worksheet_SelectionChange(ByVal Target As Range)程序
作者: donod    時間: 2012-2-28 15:09

回復 14# GBKEE


    謝謝大大回覆!
但第1張工作頁錯在什麼，請大大指教!
[attach]9793[/attach]
作者: register313    時間: 2012-2-28 15:17

回復 15# donod
  1. Option Explicit
  2. Private Sub Worksheet_SelectionChange(ByVal Target As Range)
  3. Dim xX As Integer, Ar(), A As Range, B As Range, i As Integer, x As Variant
  4. If Target.Address(0, 0) = "Q8" Then       '選擇了 Q8
  5.     Set B = Range("V9:AJ20")              '制訂 B 組(分數- PT8) 範圍
  6.     xX = 0                                ' Q欄
  7. ElseIf Target.Address(0, 0) = "R8" Then   '選擇了 R8
  8.     Set B = Range("AM9:BA20")             '制訂 C組(分數-PT8) 範圍
  9.     xX = 1                                ' P欄 右移一欄 :R欄
  10. ElseIf Target.Address(0, 0) = "S8" Then   '選擇了 S8
  11.     Set B = Range("BD9:BR20")             '制訂 D組(分數-PT8) 範圍
  12.     xX = 2                                ' P欄 右移二欄 :S欄
  13. ElseIf Target.Address(0, 0) = "T8" Then   '選擇了 T8
  14.     Set B = Range("BU9:CI20")             '制訂 E組(分數-PT8) 範圍
  15.     xX = 3                                ' P欄 右移三欄 :T欄
  16. Else
  17.     Exit Sub                              '離開程序
  18. End If
  19. Set A = Range("G9:P20")                   '制訂 A 組(PT1-PT8) 範圍
  20. A.Interior.ColorIndex = xlNone            '清除A 組(PT1-PT8) 範圍圖樣
  21. B.Interior.ColorIndex = xlNone            '清除B ,C , D. 組 範圍圖樣
  22. ReDim Ar(1 To A.Rows.Count)               '重新宣告 陣列的維數
  23. For i = 1 To B.Rows.Count                 '取得B,C,D,組的 (PT1-PT8) 的內容  置入陣列 Ar
  24.     Ar(i) = Join(Application.Transpose(Application.Transpose(B(i, 6).Resize(, 10))), ",")
  25. Next
  26. For i = 1 To A.Rows.Count
  27.     x = Join(Application.Transpose(Application.Transpose(A(i, 1).Resize(, 10))), ",")
  28.     x = Application.Match(x, Ar, 0)       '工作表函數Match 在Ar尋找 相同字串
  29.     A(i, 11 + xX) = ""                    '清除
  30.     If Not IsError(x) Then                '找到傳回數字
  31.         B(x, 6).Resize(, 10).Interior.ColorIndex = 6
  32.         A(i, 1).Resize(, 10).Interior.ColorIndex = 6
  33.         A(i, 11 + xX) = B(x, 1)           'B,C,D,E組的分數
  34.     End If
  35. Next
  36. End Sub
複製代碼
另外建議每張工作表應有相同之格式(可以作到的),這樣就可以只用一個活頁簿模組
如每張工作表之格式不同,那就要每張工作表分別放工作表模組
作者: GBKEE    時間: 2012-2-28 16:11

回復 15# donod
With Target
        If Target.Address(0, 0) = "Q8" Then         '選擇了 Q8
            Set B = .Range("V9:AJ20")              '制訂 B 組(分數- PT8) 範圍
            B.Select    '   ***  加上這行看看  B的範圍在哪裡

16# 修改為 Set B = Range("V9:AJ20")   少了 一個點 Set B = .Range("V9:AJ20")    就正確了
有這 一點 代表是 以 With Target 為基點 所擴展的範圍
作者: donod    時間: 2012-2-28 17:14

回復 16# register313


   可以了! 謝謝大大!
作者: donod    時間: 2012-2-28 17:18

回復 17# GBKEE


    謝謝大大!這樣修改正確嗎?
[attach]9796[/attach]
作者: GBKEE    時間: 2012-2-28 20:36

回復 19# donod
如此只有SHEETS("1" )有程式碼可以, 其他工作表沒有是沒有動作的
作者: donod    時間: 2012-2-28 21:56

回復 20# GBKEE


    明白，就如兩位大大所說，每張工作表有相同之格式是最方便。
再次謝謝兩位大大教導!
作者: donod    時間: 2012-2-29 00:09

回復 20# GBKEE


    現在改用Workbook，但用了較多數據，沒有顯示結果，煩請大大檢查，謝謝!
[attach]9801[/attach]
作者: register313    時間: 2012-2-29 00:47

回復 22# donod
  1. Option Explicit
  2. 'ThisWorkbook 的預設事件
  3. Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)
  4. Dim xX As Integer, Ar(), A As Range, B As Range, i As Integer, x As Variant
  5. With Sh
  6.     If Target.Address(0, 0) = "R8" Then         '選擇了 P7
  7.         Set B = Range("Z9:AO1500")              '制訂 B 組(最頂1個利潤- 最後最底1個OPT) 範圍
  8.         '而Set B = .Range("V9:AJ20"), Range之前 有 一點 代表是 以 With Target 為基點 所擴展的範圍
  9.         '  B.Select                             ' 加上這行 可顯示 B的範圍在哪裡
  10.         xX = 0                                  ' P欄
  11.     ElseIf Target.Address(0, 0) = "S8" Then     '選擇了 Q7
  12.         Set B = Range("AR9:BG1500")             '制訂 C組(最頂1個利潤- 最後最底1個OPT) 範圍
  13.         'B.Select
  14.         xX = 1                                  ' P欄 右移一欄 :Q欄
  15.     ElseIf Target.Address(0, 0) = "T8" Then     '選擇了 R7
  16.         Set B = Range("BJ9:BY1500")             '制訂 D組(最頂1個利潤- 最後最底1個OPT) 範圍
  17.         xX = 2                                  ' P欄 右移二欄 :R欄
  18.     ElseIf Target.Address(0, 0) = "U8" Then     '選擇了 Q7
  19.         Set B = Range("CB9:CQ1500")             '制訂 C組(最頂1個利潤- 最後最底1個OPT) 範圍
  20.         xX = 3                                  ' P欄 右移3欄 :Q欄
  21.     ElseIf Target.Address(0, 0) = "V8" Then     '選擇了 R7
  22.         Set B = Range("CT9:DI1500")             '制訂 D組(最頂1個利潤- 最後最底1個OPT) 範圍
  23.         xX = 4                                  ' P欄 右移4欄 :R欄
  24.     ElseIf Target.Address(0, 0) = "W8" Then     '選擇了 R7
  25.         Set B = Range("DL9:EA1500")             '制訂 D組(最頂1個利潤- 最後最底1個OPT) 範圍
  26.         xX = 5                                  ' P欄 右移5欄 :R欄
  27.     Else
  28.         Exit Sub                                '離開程序
  29.     End If
  30.     Set A = Range("H9:Q1500")                   '制訂 A 組(全部OPT) 範圍
  31.     A.Interior.ColorIndex = xlNone              '清除A 組(OPT1-OPT10) 範圍圖樣
  32.     B.Interior.ColorIndex = xlNone              '清除B ,C , D. 組 範圍圖樣
  33.     ReDim Ar(1 To A.Rows.Count)                 '重新宣告 陣列的維數
  34.     For i = 1 To B.Rows.Count                   '取得B,C,D,組的 (OPT1-OPT10) 的內容  置入陣列 Ar
  35.         Ar(i) = Join(Application.Transpose(Application.Transpose(B(i, 7).Resize(, 10))), ",")
  36.     Next
  37.     For i = 1 To A.Rows.Count
  38.         x = Join(Application.Transpose(Application.Transpose(A(i, 1).Resize(, 10))), ",")
  39.         x = Application.Match(x, Ar, 0)         '工作表函數Match 在Ar尋找 相同字串
  40.         A(i, 11 + xX) = ""                      '清除
  41.         If Not IsError(x) Then                  '找到傳回數字
  42.             B(x, 7).Resize(, 10).Interior.ColorIndex = 6
  43.             A(i, 1).Resize(, 10).Interior.ColorIndex = 6
  44.             A(i, 11 + xX) = B(x, 1)             'B,C,D,組的分數
  45.         End If
  46.     Next
  47. End With
  48. End Sub
複製代碼
作者: donod    時間: 2012-2-29 02:39

回復 23# register313


    謝謝大大!
35.        Ar(i) = Join(Application.Transpose(Application.Transpose(B(i, 7).Resize(, 10))), ",")
40.        A(i, 11 + xX) = ""
請問以上的(B(i, 7).Resize(, 10))  和  A(i, 11 + xX)是指什麼位置?
作者: register313    時間: 2012-2-29 09:23

回復 24# donod

Set B = Range("Z9:AO1500")
則B(1,1)= Range("Z9")   B(1,2)= Range("AA9")   B(1,3)= Range("AB9")  …
  B(2,1)= Range("Z10")   B(2,2)= Range("AA10")   B(2,3)= Range("AB10")  …
若i=1,則B(i, 7).Resize(, 10)= B(1, 7).Resize(, 10)= Range("AF9").Resize(, 10) = Range("AF9:AO9")
若i=2,則B(i, 7).Resize(, 10)= B(2, 7).Resize(, 10)= Range("AF10").Resize(, 10) = Range("AF10:AO10")

Set A = Range("H9:Q1500")
若xX=0,i=1,則A(i, 11 + xX)= A(1, 11)= Range("R9")
若xX=0,i=2,則A(i, 11 + xX)= A(2, 11)= Range("R10")
作者: donod    時間: 2012-2-29 11:06

回復 25# register313


    謝謝大大回覆!明白更多了。
如果其他組首300個PT組合個別跟A組首50個PT組合配對，請教應如何改寫?
作者: register313    時間: 2012-2-29 11:57

回復 26# donod

看看對不對
  1. Option Explicit
  2. 'ThisWorkbook 的預設事件
  3. Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)
  4. Dim xX As Integer, Ar(), Br(), A As Range, B As Range, i As Integer, x As Variant
  5. With Sh
  6.     If Target.Address(0, 0) = "R8" Then         '選擇了 P7
  7.         Set B = Range("Z9:AO9").Resize(300)     '制訂 B 組(最頂1個利潤- 最後最底1個OPT) 範圍
  8.         '而Set B = .Range("V9:AJ20"), Range之前 有 一點 代表是 以 With Target 為基點 所擴展的範圍
  9.         '  B.Select                             ' 加上這行 可顯示 B的範圍在哪裡
  10.         xX = 0                                  ' P欄
  11.     ElseIf Target.Address(0, 0) = "S8" Then     '選擇了 Q7
  12.         Set B = Range("AR9:BG9").Resize(300)    '制訂 C組(最頂1個利潤- 最後最底1個OPT) 範圍
  13.         'B.Select
  14.         xX = 1                                  ' P欄 右移一欄 :Q欄
  15.     ElseIf Target.Address(0, 0) = "T8" Then     '選擇了 R7
  16.         Set B = Range("BJ9:BY9").Resize(300)    '制訂 D組(最頂1個利潤- 最後最底1個OPT) 範圍
  17.         xX = 2                                  ' P欄 右移二欄 :R欄
  18.     ElseIf Target.Address(0, 0) = "U8" Then     '選擇了 Q7
  19.         Set B = Range("CB9:CQ9").Resize(300)    '制訂 C組(最頂1個利潤- 最後最底1個OPT) 範圍
  20.         xX = 3                                  ' P欄 右移3欄 :Q欄
  21.     ElseIf Target.Address(0, 0) = "V8" Then     '選擇了 R7
  22.         Set B = Range("CT9:DI9").Resize(300)    '制訂 D組(最頂1個利潤- 最後最底1個OPT) 範圍
  23.         xX = 4                                  ' P欄 右移4欄 :R欄
  24.     ElseIf Target.Address(0, 0) = "W8" Then     '選擇了 R7
  25.         Set B = Range("DL9:EA9").Resize(300)    '制訂 D組(最頂1個利潤- 最後最底1個OPT) 範圍
  26.         xX = 5                                  ' P欄 右移5欄 :R欄
  27.     Else
  28.         Exit Sub                                '離開程序
  29.     End If
  30.     Set A = Range("H9:Q9").Resize(50)                   '制訂 A 組(全部OPT) 範圍
  31.     A.Interior.ColorIndex = xlNone              '清除A 組(OPT1-OPT10) 範圍圖樣
  32.     B.Interior.ColorIndex = xlNone              '清除B ,C , D. 組 範圍圖樣
  33.   ' ReDim Ar(1 To A.Rows.Count)                 '重新宣告 陣列的維數
  34.     ReDim Br(1 To B.Rows.Count)
  35.     For i = 1 To B.Rows.Count                   '取得B,C,D,組的 (OPT1-OPT10) 的內容  置入陣列 Ar
  36.         Br(i) = Join(Application.Transpose(Application.Transpose(B(i, 7).Resize(, 10))), ",")
  37.     Next
  38.     For i = 1 To A.Rows.Count
  39.         x = Join(Application.Transpose(Application.Transpose(A(i, 1).Resize(, 10))), ",")
  40.         x = Application.Match(x, Br, 0)         '工作表函數Match 在Ar尋找 相同字串
  41.         A(i, 11 + xX) = ""                      '清除
  42.         If Not IsError(x) Then                  '找到傳回數字
  43.             B(x, 7).Resize(, 10).Interior.ColorIndex = 6
  44.             A(i, 1).Resize(, 10).Interior.ColorIndex = 6
  45.             A(i, 11 + xX) = B(x, 1)             'B,C,D,組的分數
  46.         End If
  47.     Next
  48. End With
  49. End Sub
複製代碼
作者: donod    時間: 2012-2-29 12:36

回復 27# register313


    可行了，也知多點，謝謝大大教導!



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