- 帖子
- 4901
- 主題
- 44
- 精華
- 24
- 積分
- 4916
- 點名
- 244
- 作業系統
- Windows 7
- 軟體版本
- Office 20xx
- 閱讀權限
- 150
- 性別
- 男
- 來自
- 台北
- 註冊時間
- 2010-4-30
- 最後登錄
- 2024-11-10
              
|
32#
發表於 2012-2-7 18:27
| 只看該作者
回復 31# tonycho33
試試看- Private Sub Worksheet_Activate()
- Set d = CreateObject("Scripting.Dictionary")
- Set d1 = CreateObject("Scripting.Dictionary")
- With Sheet6
- For Each A In .Range("I2", .[I65536].End(xlUp)).SpecialCells(xlCellTypeConstants)
- If A <> "" And A.Offset(, 1) = "" Then
- mystr = Join(Application.Transpose(Application.Transpose(A.Offset(, -8).Resize(, 5).Value)), "")
- d(mystr) = d(mystr) + 1
- ElseIf A.Offset(, 1) - A Then
- mystr = Join(Application.Transpose(Application.Transpose(A.Offset(, -8).Resize(, 5).Value)), "")
- d1(mystr) = d1(mystr) + 1
- End If
- Next
- End With
- With Me
- r = 2
- Do Until .Cells(r, 1) = ""
- Set A = .Cells(r, 1)
- mystr = A & A.Offset(, 1)
- For Each c In .Range(A.Offset(, 6), A.Offset(, 6).End(xlToRight))
- temp = mystr & Join(Application.Transpose(c.Resize(3, 1)), "")
- If d.exists(temp) = True Then
- c.Resize(3, 1).Interior.ColorIndex = 4
- ElseIf d1.exists(temp) = True Then
- c.Resize(3, 1).Interior.ColorIndex = 6
- Else
- c.Resize(3, 1).Interior.ColorIndex = 0
- End If
- Next
- r = r + 3
- Loop
- End With
- End Sub
|
|
發表於 2012-2-7 16:06
| 
