[發問] VBA_加入將各同欄位的相同值(交集值)標示底色的程式碼_2。

Airman

VBA_3AC_4_對應列的同欄交集值標示底色。.rar (25.46 KB)

下載次數: 2

2015-12-25 17:40

以下程式語法~請再加入一段︰
將各同欄位的相同值(交集值)標示底色的程式碼。
詳細圖示如附件。
謝謝!

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

准提部林

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

回復 2# 准提部林

准大:
呵~呵~前些日子您所賜教的公式和程式語法~小弟到今天才消化整理完畢~但就是一個限同欄位才標示底色的語法一直轉化(套)不過來
謝謝您的耐心指導~測試OK了~感恩

新年快樂