返回列表 上一主題 發帖

[發問] 改變儲存格顏色

[發問] 改變儲存格顏色

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                  
上述程式是網路上所寫的程式
                            
若滑鼠移到"表格內已設定格式化條件的儲存格"的位置時,不會改變原格式化的條件
設定(只是改變顏色而已)。
請教高手要如何改寫上述程式。

儲存格顏色改變.zip (10.9 KB)

回復 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
程式是依需求寫的,需求表達不清楚
或者沒有上傳附件,愛莫能助

TOP

回復 2# n7822123

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

TOP

回復 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
程式是依需求寫的,需求表達不清楚
或者沒有上傳附件,愛莫能助

TOP

本帖最後由 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
程式是依需求寫的,需求表達不清楚
或者沒有上傳附件,愛莫能助

TOP

回復 5# n7822123

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

TOP

        靜思自在 : 【時間無法遮擋】怕時間消逝,花了許多心血,想盡各式方法要遮擋時間,結果是:浪費了更多時間,且一無所成!
返回列表 上一主題