標題: [發問] VBA_二個程式合併後的底色標示之語法修正。 [打印本頁]

---

作者: Airman    時間: 2016-1-28 22:00     標題: VBA_二個程式合併後的底色標示之語法修正。

[attach]23199[/attach]

下列二個程式只有列11有差異，其餘都相同。
A區和B區的【任一列】對應列交集值=C區~同欄&不限同欄
Private Sub CommandButton1_Click()
Dim b As Range, RW, R(1 To 3) As Range, UR(1 To 3) As Range, x%, z%, i%, U%

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
      
          RW = Array(b(1, -1), .[T5], .[R6])    '列11
          For x = 1 To 4
          For i = 1 To 3: Set UR(i) = Nothing: Next
          For z = 1 To 7
          Set R(1) = .[J6].Cells(RW(0) - x + 1, z): U = 0
              For i = 2 To 3
              Set R(i) = Nothing
              'Set R(i) = .[J6:P6].Offset(RW(i - 1) - x, 0).Find(R(1), Lookat:=xlWhole) '不同欄
              'If Not R(i) Is Nothing Then U = U + i '不同欄
              Set R(i) = .[J6:P6].Cells(RW(i - 1) - x + 1, z) '同欄
              If R(i) = R(1) Then U = U + i '同欄
              Next i
          If U = 2 Then Set UR(1) = Nothing: Exit For
          If U = 5 Then
          For i = 1 To 3
              If UR(i) Is Nothing Then Set UR(i) = R(i) Else Set UR(i) = Union(UR(i), R(i))
          Next i
          End If
          Next z
          If Not UR(1) Is Nothing Then
          For i = 1 To 3
          For Each R(1) In UR(i): R(1).Interior.ColorIndex = Array(8, 4, 6)(i - 1): Next
          Next i
          End If
          Next x
         
          End If
          End If
      Next b
      .[A1].Select
End With
End Sub

C區和B區的【任一列】對應列交集值=A區~同欄&不限同欄
Private Sub CommandButton1_Click()
︰
︰
︰
          RW = Array(.[R6], .[T5], b(1, -1))    '列11
︰
︰
︰
End Sub

今將上述二個程式合併後成為~
A區和B區的【任一列】對應列交集值=C區&C區和B區的【任一列】對應列交集值=A區~同欄&不限同欄的程式檔案~
其底色無法達成如T7公式的需求~
即如範例檔的輔助圖示W︰AC和AJ︰AP同時有標示同樣底色時，J︰P才標示同樣底色~
(即N91，N102，N105的儲存格沒有標示底色才是正確的)

請問︰應該如何修正合併的程式碼，才能達到如範例檔的J︰P之正確底色標示?

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

---

作者: Airman    時間: 2016-1-29 02:50

本帖最後由 Airman 於 2016-1-29 02:51 編輯

補充說明:
A區和B區的【任一列】對應列交集值=C區~同欄&不限同欄
的原題意和程式請詳見:  http://forum.twbts.com/thread-16067-1-1.html  #5和#6
謝謝!

---

作者: 准提部林    時間: 2016-1-29 21:32

在上方先定義以下變數：
Dim SW, H(1 To 3) As Range, V%
　
　
RW = Array(b(1, -1), .[T5], .[R6])
SW = Array(.[R6], .[T5], b(1, -1))
For x = 1 To 4
For i = 1 To 3: Set UR(i) = Nothing: Next
　　For z = 1 To 7
　　　　Set R(1) = .[J6].Cells(RW(0) - x + 1, z): U = 0
　　　　Set H(1) = .[J6].Cells(SW(0) - x + 1, z): V = 0
　　　　For i = 2 To 3
　　　　　　Set R(i) = Nothing
　　　　　　Set R(i) = .[J6:P6].Cells(RW(i - 1) - x + 1, z) '同欄
　　　　　　If R(i) = R(1) Then U = U + i '同欄
　
　　　　　　Set H(i) = Nothing
　　　　　　Set H(i) = .[J6:P6].Cells(SW(i - 1) - x + 1, z)
　　　　　　If H(i) = H(1) Then V = V + i
　　　　Next i
　　　　If U = 2 Or V = 2 Then Set UR(1) = Nothing: Exit For
　　　　If U = 5 And V = 5 Then
　　　　　　For i = 1 To 3
　　　　　　　　If UR(i) Is Nothing Then Set UR(i) = R(i) Else Set UR(i) = Union(UR(i), R(i))
　　　　　　Next i
　　　　End If
　　Next z
　
　　If Not UR(1) Is Nothing Then
　　　　For i = 1 To 3
　　　　　　For Each R(1) In UR(i): R(1).Interior.ColorIndex = Array(8, 4, 6)(i - 1): Next
　　　　Next i
　　End If
Next x

---

作者: Airman    時間: 2016-1-30 07:18

回復 3# 准提部林
准大:
測試OK了~謝謝您

萬分感激您一再耐心賜教~感恩

---

歡迎光臨 麻辣家族討論版版 (http://forum.twbts.com/)