Private Sub CommandButton1_Click()
Dim b As Range, RW, y%
With Sheets(2)
Sheets(1).Range("J7", "P" & Sheets(2).[R6] + 5).Copy .[J7]
Application.Goto .Range("T7:T" & .[R7].End(xlDown).Row) '不用Select，直接跳選目標區
For Each b In Selection
If b <> "" Then
If .Range("R" & b.Row) < .[T5] And .Range("R" & b.Row) - 4 > 0 Then
Dim R(1 To 3) As Range, x%, z%, i%, U%
RW = Array(.[T5], .[R6], b(1, -1))
For x = 1 To 4
For y = 1 To 3
For z = 1 To 7
Set R(1) = .[J6].Cells(RW(y - 1) - x + 1, z)
Set R(2) = Nothing
For i = 1 To 3
If i <> y Then Set R(2) = .[J6:P6].Offset(RW(i - 1) - x, 0).Find(R(1), Lookat:=xlWhole)
If Not R(2) Is Nothing Then R(1).Interior.ColorIndex = Array(4, 6, 8)(y - 1): Exit For
Next i
Next z
Next y
Next x
End If
End If
Next b
.[A1].Select
End With
End Sub作者: 准提部林 時間: 2015-12-25 18:46
For z = 1 To 7
Set R(1) = .[J6].Cells(RW(y - 1) - x + 1, z): U = 0
For i = 1 To 3
Set R(2) = Nothing
If i <> y Then Set R(2) = .[J6:P6].Offset(RW(i - 1) - x, 0).Find(R(1), Lookat:=xlWhole)
If Not R(2) Is Nothing Then If R(2).Column = R(1).Column Then U = U + 1
Next i
If Val(U) = 2 Then R(1).Interior.ColorIndex = Array(4, 6, 8)(y - 1)
Next z
＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝
或:：
For z = 1 To 7
Set R(1) = .[J6].Cells(RW(y - 1) - x + 1, z): U = 0
For i = 1 To 3
If i <> y Then If R(1) = .[J6].Cells(RW(i - 1) - x + 1, z) Then U = U + 1
Next i
If Val(U) = 2 Then R(1).Interior.ColorIndex = Array(4, 6, 8)(y - 1)
Next z作者: Airman 時間: 2015-12-25 19:16
