返回列表下一主題上一主題發帖

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

Airman

中學生 Rank: 2

帖子: 315
主題: 51
精華: 0
積分: 367
點名: 0
作業系統: win7
軟體版本: office2003
閱讀權限: 20
性別: 男
註冊時間: 2015-9-29
最後登錄: 2021-10-12

1^# 跳轉到 » 倒序看帖

打印

字體大小: tT

發表於 2015-12-25 17:41 | 只看該作者

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

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

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

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

樓主熱帖

准提部林

版主 Rank: 7 Rank: 7 Rank: 7

帖子: 2833
主題: 10
精華: 0
積分: 2889
點名: 0
作業系統: 〔略〕
軟體版本: 〔略〕
閱讀權限: 100
性別: 男
來自: 〔略〕
註冊時間: 2013-5-13
最後登錄: 2024-11-16

2^#

發表於 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

TOP

Airman