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的外观：

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

如果格式化单元格

1 个答案: