標題: [發問] 改變儲存格顏色 [打印本頁]

---

作者: Hyuan    時間: 2018-12-4 19:05     標題: 改變儲存格顏色

Private Sub Worksheet_SelectionChange(ByVal Target As Excel.Range)
If Application.CutCopyMode = xlCopy Then Me.Paste
On Error Resume Next
[colorCell].FormatConditions.Delete
Target.Name = "colorCell"
With [colorCell].FormatConditions ' 設定格式化條件
.Delete        　        　
.Add xlExpression, , "TRUE" ' 條件(一)內公式為
.Item(1).Interior.ColorIndex = 40 ' .Item(1)等於FormatConditions(1)
.Item(1).Font.Bold = True
End With        　        　
End Sub        　        　
上述程式是網路上所寫的程式
　        　        　        　
若滑鼠移到"表格內已設定格式化條件的儲存格"的位置時，不會改變原格式化的條件
設定(只是改變顏色而已)。
請教高手要如何改寫上述程式。

---

作者: n7822123    時間: 2018-12-4 23:40

回復 1# Hyuan


若滑鼠移到"表格內已設定格式化條件的儲存格"的位置時，不會改變原格式化的條件
設定(只是改變顏色而已)。

呵呵，你的問題很有意思!
不管儲存格格式是什麼顏色，格式化條件的效果會覆蓋掉原本的儲存格格式
所以你要改變有格式化條件的儲存格顏色，必須先移除該格的格式化條件
但是這樣就會不知道當初的格式化條件，所以要先複製格式化條件到其它格

順序如下:
1.複製點選的格式化條件到某一格(我的程式是最後一格)
2.刪除點選的格式化條件
3.為點選的儲存格上顏色
4.當點到其它儲存格時，把最後一個的格式化條件複製回上一格

程式如下:
Dim pre As Range
Private Sub Worksheet_SelectionChange(ByVal Target As Excel.Range)
Application.ScreenUpdating = False
Application.EnableEvents = False
If Application.CutCopyMode = xlCopy Then Me.Paste
On Error Resume Next
If Not pre Is Nothing Then
  Cells(Rows.Count, Columns.Count).Copy
  pre.PasteSpecial Paste:=xlPasteFormats
End If
Target.Copy
Cells(Rows.Count, Columns.Count).PasteSpecial Paste:=xlPasteFormats
Application.CutCopyMode = False: Target.Select
Target.FormatConditions.Delete
Target.Interior.ColorIndex = 40
Set pre = Target
Application.EnableEvents = True
End Sub

---

作者: Hyuan    時間: 2018-12-5 06:26

回復 2# n7822123

謝謝大大的幫忙。完全符合我的需求，但是我發現另一個問題:
當游標移動到儲存格時反應有點慢不自然(好像在運作一直在打圈圈，如果資料多時更慢)。
再請教大大解決。

---

作者: n7822123    時間: 2018-12-5 11:40

回復 3# Hyuan


我自己嘗試，沒有這個狀況耶，

應該是你有不少函數觸發自動重算，加上這兩行試試

Dim pre As Range
Private Sub Worksheet_SelectionChange(ByVal Target As Excel.Range)
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlManual
If Application.CutCopyMode = xlCopy Then Me.Paste
On Error Resume Next
If Not pre Is Nothing Then
  Cells(Rows.Count, Columns.Count).Copy
  pre.PasteSpecial Paste:=xlPasteFormats
End If
Target.Copy
Cells(Rows.Count, Columns.Count).PasteSpecial Paste:=xlPasteFormats
Application.CutCopyMode = False: Target.Select
Target.FormatConditions.Delete
Target.Interior.ColorIndex = 40
Set pre = Target
Application.EnableEvents = True
Application.Calculation = xlAutomatic
End Sub

---

作者: n7822123    時間: 2018-12-5 13:01

本帖最後由 n7822123 於 2018-12-5 13:06 編輯

回復 4# n7822123

發現小BUG，關掉自動重算會讓自動貼上失效
修改一下順序

Dim pre As Range
Private Sub Worksheet_SelectionChange(ByVal Target As Excel.Range)
Application.ScreenUpdating = False
Application.EnableEvents = False
On Error Resume Next
If Application.CutCopyMode = xlCopy Then Me.Paste
Application.Calculation = xlManual
If Not pre Is Nothing Then
  Cells(Rows.Count, Columns.Count).Copy
  pre.PasteSpecial Paste:=xlPasteFormats
End If
Target.Copy
Cells(Rows.Count, Columns.Count).PasteSpecial Paste:=xlPasteFormats
Application.CutCopyMode = False: Target.Select
Target.FormatConditions.Delete
Target.Interior.ColorIndex = 40
Set pre = Target
Application.EnableEvents = True
Application.Calculation = xlAutomatic
End Sub

---

作者: Hyuan    時間: 2018-12-5 20:06

回復 5# n7822123

再次謝謝大大的幫忙，解決了我的問題。

---

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