GBKEE

回復 29# Airman
有一個(含)以上的交集值(07,39)時
交集值 應有規律性,可讓程式去設定
試試看

1. Option Explicit
   
2. Private Sub CommandButton1_Click()
   
3.     Dim b As Range, Rng As Range, E, C As Variant, Ar(), x_No, x As Variant
   
4.     Dim xRng As Range, Color_Ar(), i As Integer
   
5.     x_No = Array(7, 39)
   
6.     Color_Ar = Array(4, 45, 8)
   
7.     With Sheets(2)
   
8.         .Activate   '將目前的工作表成為使用中的工作表。等同於按一下工作表索引標籤。
   
9.         Sheets(1).Range("J7", "P" & Sheets(2).[R6] + 5).Copy .[J7]
   
10.         Set Rng = .Range("J7:P" & .[R6] + 5)                '所複製資料的範圍
    
11.         Set xRng = .Range("T7:T" & .[R6] + 5)               'T欄的範圍
    
12.         If Application.Count(xRng) = 0 Then Exit Sub        'T欄沒有期數時離開程式
    
13.         For Each b In xRng.SpecialCells(xlCellTypeConstants) 'T欄 [有期數的儲存格]範圍
    
14.             Ar = Array(.Range("R" & b.Row).Value, .Range("R" & b.Row) - .[T3], .Range("R" & b.Row) - .[T3] * 2) '期別的陣列
    
15.             '陣列:其在R欄的對應期數
    
16.             For i = 0 To UBound(Ar)                 '陣列元素下限值從0開使
    
17.                 For Each x In x_No                  '比對數字的迴圈
    
18.                     C = Application.Match(x, Rng.Rows(Ar(i)), 0) '找到傳回數字
    
19.                     If IsNumeric(C) Then Rng.Rows(Ar(i)).Cells(C).Interior.ColorIndex = Color_Ar(i)
    
20.                 Next
    
21.             Next
    
22.         Next
    
23.         .[a1].Select  '滑鼠停留在Sheets(2)的 A1
    
24.     End With
    
25. End Sub

複製代碼

Airman

回復 31# GBKEE
GBKEE超版大:您好!
不好意思，您還將程式碼全加註解~辛苦您了!感恩

非常接近了!只剩下交集值的定義有誤差~
先假設ARR=.Range("R" & b.Row),.Range("R" & b.Row)-T$3, .Range("R" & b.Row)-T$3*2三個期數的範圍，以利說明。

目前貴程式是依據x_No = Array(m, n)是預設之固定的搜尋值~
即當m填入07，n填入39,則將在ARR有顯示07或39的儲存格各標示底色(不需要3個期數同時都有)；
又如當m填入01，n填入49,則將在ARR有顯示01或49的儲存格各標示底色(不需要3個期數同時都有)；....其餘以此類推。

本體需求的交集值是浮動的(即非預設的)~
即是依據ARR的3個期數是否同時都有相同數字來決定︰如果3個期數都有相同的數字時，則該相同數字即為交集值~
EX1_即當ARR的交集值為01(即必須3個期數同時都有01)時，則3個期數顯示01的儲存格各標示底色；
EX2_即當ARR的交集值為07,39(即必須3個期數同時都有07,39)時，則3個期數顯示07,39的儲存格各標示底色；
EX3_當ARR的交集值為08,20,40(即必須3個期數同時都有08,20,40)時，則3個期數顯示08,20,40的儲存格各標示底色；
EX4_當ARR都沒有交集值(即3個期數沒有同時都有相同的數字)時，則3個期數的儲存格都為無底色。..... 其餘以此類推。

以上 謹供參考!謝謝您!

准提部林

回復 30# Airman


x_No = Array(7, 39)　超板還是以為7,39是〔已知〕條件，所以我才說要加註說明！！^ ^

試著以如下去解說：
有Ａ．Ｂ．Ｃ三區，每區７格，每區各有７個１～４９不重覆數字，
找出這三區〔共有〕的數字並分別填入底色 （共有數字須先行檢測，無預設值），
例如下方範例，檢測後取得共同數字為：０７．３９．１３
Ａ區：

07

12

17

28

39

43

13

Ｂ區：

01

07

13

39

42

45

49

Ｃ區：

07

09

13

20

21

39

49

＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝
#11 是以〔一個數字〕去比封三區，所以較簡單，
此需求是７個數字逐一比對三區，1 To 3 及 1 To 7 迴圈省不了，因為欄位不一樣，
若要求數字及欄位相同，即如#27，用 1 To 7 迴圈即可，反而較省事；
以此需求的迴圈不算大，應還不太影響運行速度，
若減少迴圈以函數代替，也並不見得較好，畢竟函數的效率有時會降低速度～～

Airman

回復 33# 准提部林
准大:
呵~呵~還是您的解說既簡且清~小弟承教了~希望小弟下次的說明能更精準

原是想程式碼同一式體，既然您說沒有特別益處~小弟就不再執著了。

謝謝您的耐心回覆與說明~感恩

GBKEE

回復 34# Airman

參考准提部林 版主說明
試試看

1. Option Explicit
   
2. Dim Sh As Worksheet '這模組的私用變數
   
3. Private Sub CommandButton1_Click()
   
4.     Dim b As Range, Rng As Range
   
5.     Dim xRng(1 To 2) As Range
   
6.     With Sheets("Sheet1") '要呈現的工作表
   
7.         Sheets("DATA").Range("J7", "P" & .[R6] + 5).Copy .[J7]
   
8.         Set Rng = .Range("J7:P" & .[R6] + 5)                   '所複製資料的範圍
   
9.         Rng.Interior.ColorIndex = xlNone
   
10.         Set xRng(1) = .Range("T7:T" & .[R6] + 5)               'T欄的範圍
    
11.         If Application.Count(xRng(1)) = 0 Then Exit Sub        'T欄沒有期數時離開程式
    
12.         
    
13.         Set Sh = Sheets.Add(Sheets(1))                         '增加一工作表
    
14.         Application.ScreenUpdating = False                     '如果螢幕更新功能是開啟的則為 True
    
15.         For Each b In xRng(1).SpecialCells(xlCellTypeConstants) 'T欄 [有期數的儲存格]範圍
    
16.             Ex_ChiCK Union(Rng.Rows(.Range("R" & b.Row)), Rng.Rows(.Range("R" & b.Row) - .[T3]), Rng.Rows(.Range("R" & b.Row) - .[T3] * 2))  '期別的陣列
    
17.             'Ex_ChiCK Union(Rng.Rows(.Range("R" & b.Row) - .[T3] * 2), Rng.Rows(.Range("R" & b.Row) - .[T3]), Rng.Rows(.Range("R" & b.Row)))  '倒轉期別
    
18.         Next
    
19.         .Activate   '將目前的工作表成為使用中的工作表。等同於按一下工作表索引標籤。
    
20.         .[a1].Select  '滑鼠停留在Sheets(2)的 A1
    
21.     End With
    
22.     Application.DisplayAlerts = False  '如果巨集在執行時 Microsoft Excel 顯示特定的警告和訊息則為 True
    
23.     Sh.Delete                          '刪除:工作表
    
24.     Application.DisplayAlerts = True
    
25.     Application.ScreenUpdating = True
    
26. End Sub
    
27. Private Sub Ex_ChiCK(Rng As Range)  '副程式 須傳送參數
    
28.     Dim Ar(), i As Variant, E As Variant, X As Variant, M As Integer
    
29.     Ar = Array(4, 45, 8)
    
30.     Rng.Copy Sh.[a1]             '複製三期資料
    
31.     For i = 1 To 49
    
32.         X = Application.CountIf(Sh.UsedRange, i)  'x = 3 :同一號碼三期都出現
    
33.         If X = 3 Then E = E & IIf(E <> "", ",", "") & i  '紀錄號碼
    
34.     Next
    
35.     X = Split(E, ",")        '出現3次的號碼,置入陣列
    
36.     For Each E In X
    
37.         For i = 1 To Rng.Areas.Count
    
38.             '傳回 Areas 集合，此集合代表多重範圍中的所有範圍
    
39.             M = Application.Match(Val(E), Rng.Areas(i).Cells, 0)
    
40.             Rng.Areas(i).Cells(M).Interior.ColorIndex = Ar(i - 1) '依範圍傳回的顏色
    
41.         Next
    
42.     Next
    
43. End Sub

複製代碼

Airman

回復 35# GBKEE
GBKEE超版大:您好!
不好意思~只剩標示底色的問題了~
假設:A區=.Range("R" & b.Row)；B區=.Range("R" & b.Row)-T$3；C區=.Range("R" & b.Row)-T$3*2；
則3區的共有數字，依分區分別標示4號,45號,8號底色~即A區標示4號底色；B區標示45號底色；C區標示8號底色 ~
EX_1:
C區(72)：         07        10        13        20        21        39        18

Ｂ區(81)：        01        07        13        39        42        45        12

A區(90)：        07        12        17        28        40        41        49

EX_2:
C區(72)：         07        09        11        20        21        39        12

Ｂ區(81)：        01        07        13        39        42        45        10

A區(90)：        07        12        17        28        40        13        39

EX_3:
C區(72)：         07        09        13        20        21        39        12

Ｂ區(81)：        01        07        13        39        42        45        12

A區(90)：        07        10        17        28        40        13        39


EX_4:
C區(72)：         07        09        13        20        21        39        12

Ｂ區(81)：        01        07        13        39        42        45        12

  A區(90)：        07        12        17        28        40        13        39

.....其餘以此類推

以上 謹供參考!謝謝您!

准提部林

不是簡化，另一種寫法，比原使用３層迴圈更不易理解，參考罷：

RW = Array(b(1, -1), b(1, -1) - .[T3], b(1, -1) - .[T3] * 2)
For y = 1 To 3: Set R(y) = .[J:P].Rows(RW(y - 1) + 6).Cells: Next y
Dim M(1 To 3)
For k = 1 To 7
　　M(1) = k
　　For y = 2 To 3
　　　　M(y) = Application.Match(R(1)(k), R(y), 0)
　　　　If IsError(M(y)) Then M(1) = 0: Exit For
　　　　'If M(y) <> M(1) Then M(1) = 0: Exit For　'若要求〔同欄〕，加入這行　
　　Next y
　　If M(1) > 0 Then
　　　For y = 1 To 3: R(y)(M(y)).Interior.ColorIndex = Array(4, 45, 8)(y - 1): Next
　　End If
Next k

Airman

回復 37# 准提部林
准大:
感謝您費神再賜另解

PS:本想只以短消息向您致謝即可，避免虛取點數，但無奈小弟還是不習慣~總覺得問與答之間少個句點