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

1^# 跳轉到 » 倒序看帖

字體大小: tT

發表於 2015-12-25 16:51 | 只看該作者

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

VBA_3AA_4_對應列的同欄交集值標示底色。.rar (25.37 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 > 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

樓主熱帖

准提部林

版主 Rank: 7 Rank: 7 Rank: 7

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

2^#

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

TOP

Airman

中學生 Rank: 2

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

3^#

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

回復 2# 准提部林
准大:
謝謝您快速的回覆~測試OK了~感恩

TOP

Airman

中學生 Rank: 2

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

4^#

發表於 2016-1-2 08:15 | 只看該作者

VBA_二區R5值標示字顏和底色的語法。

本帖最後由 Airman 於 2016-1-2 08:17 編輯

新增需求語法︰
假設在列41插入For x = 0 To 6(即將比對範圍擴充為~$R7︰$R7 -6比對$Q$6︰$Q$6 -6)；
當各任一組對應列同時有顯示$R$5值時~則將該組二個顯示$R$5值之儲存格標示3號粗字顏及4號,8號底色。

以上懇請各位先進、前輩不吝賜教! 謝謝!

詳細說明如附件~

VBA_二區R5值標示字顏和底色的語法。.rar (32.73 KB)

TOP

Airman

中學生 Rank: 2

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

5^#

發表於 2016-1-2 09:34 | 只看該作者

回復 2# 准提部林
准大:您好!
#4為小弟今早新開的發問題~
敬請您惠予賜教為禱!感恩

TOP

准提部林

版主 Rank: 7 Rank: 7 Rank: 7

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

6^#

發表於 2016-1-2 11:35 | 只看該作者

回復 5# Airman

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

若因〔併帖〕，使不同需求條件混在一起，造成閱讀性的不便，
可向超板反應，或在發題時加注醒目文字！　

倒是類似需求的問題，已有多個參考，有時間可自行去推敲其邏輯試寫，並返覆執行測試及修改，
其實與公式相差不遠，不要在意程式長短，有時多寫幾個判斷一樣可達成目的！

TOP

Airman