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 > 1 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 7
Set R(1) = .[J6].Cells(RW(0) - x + 1, y): U = 0
For z = 2 To 3
Set R(z) = .[J6:P6].Offset(RW(z - 1) - x, 0).Find(R(1), Lookat:=xlWhole)
If R(z) Is Nothing Then U = 1: Exit For
Next z
If U = 0 Then
For i = 1 To 3: R(i).Interior.ColorIndex = Array(4, 6, 8)(i - 1): Next
End If
Next y
Next x
End If
End If
Next b
.[A1].Select
End With
End Sub作者: 准提部林 時間: 2015-12-25 17:16
For z = 2 To 3
Set R(z) = .[J6:P6].Offset(RW(z - 1) - x, 0).Find(R(1), Lookat:=xlWhole)
If R(z) Is Nothing Then U = 1: Exit For If R(z).Column <> R(1).Column Then U = 1: Exit For
Next z作者: Airman 時間: 2015-12-25 17:49
If .Range("R" & b.Row) - 6 > 0 And .[Q6] > .Range("R" & b.Row) Then
For x = 0 To 6
U = 0
For y = 1 To 2
Set R(y) = Nothing
Set R(y) = .[J6:P6].Offset(RW(y - 1) - x, 0).Find(.[R5], Lookat:=xlWhole)
If R(y) Is Nothing Then Exit For
'If R(y).Column <> R(1).Column Then Exit For '同欄加此行
U = U + 1
Next y
If U = 2 Then
For y = 1 To 2
R(y).Interior.ColorIndex = Array(8, 4)(y - 1)
R(y).Font.ColorIndex = 3
R(y).Font.FontStyle = "粗體"
Next y
End If
Next x
End If
].Rows(RW(y - 1) + 6).Find(.[R5], Lookat:=xlWhole) 