如果公式格式化單元格

Question

我有一個公共函數我試圖運行，看看列C中的格式，並將一個基於G列格式的值與點擊一個命令按鈕。我想用黃色突出顯示的行來獲得一個零，那些沒有內部並且沒有刪除線的可以獲得一個。我寫了下面的代碼，但是當我點擊命令按鈕時，什麼也沒有發生。不知道我的代碼是否在正確的位置或錯誤的語法？任何和所有的幫助表示讚賞。

Sub Resort() 
Dim ws As Worksheet 
Dim rng As Range 
Dim urng As Range 
Dim rng1 As Range 
Dim shCmt As Comment 
Set ws = Worksheets("Workbench Report") 
lastrow = ws.Cells(ws.Rows.count, "D").End(xlUp).Row 

ws.Select 
ws.Range(Cells(2, "B"), Cells(Cells(2, "E").End(xlDown).Row, "G")).Sort _ 
key1:=ws.Range("E1"), order1:=xlAscending, Header:=xlYes, Orientation:=xlSortColumns 

ws.Columns("E:E").EntireColumn.AutoFit 
ws.Columns("E:E").ColumnWidth = 6.86 

ws.Select 
For Each rng In ws.Range("C2:C" & lastrow) 
If rng.Interior.Color = 65535 Then 
If urng Is Nothing Then 
Set urng = ws.Range("E" & rng.Row) 
Else 
Set urng = Union(urng, ws.Range("E" & rng.Row)) 
End If 
End If 
Next rng 

If Not urng Is Nothing Then urng.copy 

ws.Range("B" & Cells.Rows.count).End(xlUp).Offset(2, 3).PasteSpecial xlPasteValues 

ws.Range("H2").PasteSpecial xlPasteValues 

ws.Range("B" & Cells.Rows.count).End(xlUp).Offset(2, 2).Select 
Selection.Formula = "=IF(H2>0,COUNTIF(E:E,H2)-2,"""")" 
Selection.HorizontalAlignment = xlCenter 
Selection.copy 
Selection.PasteSpecial Paste:=xlPasteValues 

ws.Range("B" & Cells.Rows.count).End(xlUp).Offset(3, 2).Select 
Selection.Formula = "=IF(H3>0,COUNTIF(E:E,H3)-2,"""")" 
Selection.HorizontalAlignment = xlCenter 
Selection.copy 
Selection.PasteSpecial Paste:=xlPasteValues 

ws.Range("B" & Cells.Rows.count).End(xlUp).Offset(4, 2).Select 
Selection.Formula = "=IF(H4>0,COUNTIF(E:E,H4)-2,"""")" 
Selection.HorizontalAlignment = xlCenter 
Selection.copy 
Selection.PasteSpecial Paste:=xlPasteValues 

ws.Range("B" & Cells.Rows.count).End(xlUp).Offset(5, 2).Select 
Selection.Formula = "=IF(H5>0,COUNTIF(E:E,H5)-2,"""")" 
Selection.HorizontalAlignment = xlCenter 
Selection.copy 
Selection.PasteSpecial Paste:=xlPasteValues 

ws.Range("B" & Cells.Rows.count).End(xlUp).Offset(6, 2).Select 
Selection.Formula = "=IF(H6>0,COUNTIF(E:E,H6)-2,"""")" 
Selection.HorizontalAlignment = xlCenter 
Selection.copy 
Selection.PasteSpecial Paste:=xlPasteValues 

ws.Columns("H").ClearContents 

SendKeys ("{ESC}") 

ws.Select 
ws.Range("E2").Select 
End Sub 

Public Function ColorIndex(rng As Range) As Boolean 

For Each rng In ws.Range("C2:C" & lastrow) 
If rng.Interior.Color = 65535 Then 
ws.Range("G" & rng.Row).Value = "0" 
End If 
Next rng 

For Each rng In ws.Range("C2:C" & lastrow) 
If rng.Interior.Color = xlNone And rng.Font.Strikethrough = False Then 
ws.Range("G" & rng.Row).Value = "1" 
End If 
Next rng 

End Function 

Answer 1

就像我說在我的意見，你不能使用Function作用於多個小區，你已經做的方式。你有兩個選擇。 （a）重寫以使函數僅作用於參數中提供的單元格。
（b）改爲撥打Sub，即可從命令按鈕調用。

這裏的函數的外觀：

Function ColorIndex(rng As Range) As Boolean 
    If rng.Item(1).Interior.Color = 65535 Then ColorIndex = "0" 
    If rng.Item(1).Interior.Color = 16777215 And rng.Item(1).Font.Strikethrough = False Then ColorIndex = "1" 
End Function 

放入G列，就像這樣：=ColorIndex(C2)，並填寫了下來。

這裏的子會怎樣看：

Sub ColorIndex(rng As Range) 
    For Each r In rng 
     If r.Interior.Color = 65535 Then ws.Range("G" & r.Row).Value = "0" 
     If r.Interior.Color = 16777215 And r.Font.Strikethrough = False Then ws.Range("G" & r.Row).Value = "1" 
    Next r 
End Sub 

分配到命令按鈕宏：

Sub buttonColorIndex() 
    Call ColorIndex(ws.Range("C2:C" & lastrow)) 
End Sub 

編輯：我知道你沒有問這個問題，但這裏有一個建議在代碼中進行其他優化。

你有幾段這樣看：

ws.Range("B" & Cells.Rows.count).End(xlUp).Offset(2, 2).Select 
Selection.Formula = "=IF(H2>0,COUNTIF(E:E,H2)-2,"""")" 
Selection.HorizontalAlignment = xlCenter Selection.copy 
Selection.PasteSpecial Paste:=xlPasteValues 

所有的人都刪除，並嘗試這個：

With ws.Range("B" & Cells.Rows.Count).End(xlUp) 
    For i = 2 To 6 
     With .Offset(i, 2) 
      .Value = ws.Evaluate("IF(H3>0,COUNTIF(E:E,H" & i & ")-2,"""")") 
      .HorizontalAlignment = xlCenter 
     End With 
    Next i 
End With