通过互联网搜索，我找到了一些创建countIf函数的代码，如果其中有删除线文本，则不会对单元格进行计数。
Function MyCountif(rng As Range, s As String)
Application.Volatile
Dim i As Long, s1 As String, cell As Range
If Len(s) <> 1 Then
MyCountif = CVErr(xlErrValue)
Exit Function
End If
For Each cell In rng
For i = 1 To Len(cell.Text)
s1 = Mid(cell.Text, i, 1)
If LCase(s1) = LCase(s) Then
If cell.Characters(i, 1).Font.Strikethrough = False Then
MyCountif = MyCountif + 1
End If
End If
Next
Next
End Function
我想知道是否可以创建一个类似的函数，而是以countIfs函数的形式，也可以忽略删除线文本。
编辑：我没有大量的vba经验，但我确实自己尝试过。因为我需要它只需要两个范围和两个标准我试图将原始函数运行两次并且如果两个标准都满足它会将计数提高一个但我还没有完全使用它。
Function MyCountif(rng As Range, s As String, rng2 As Range, p As String)
Application.Volatile
Dim i As Long, numbers(3) As Integer, numbers2(3) As Integer, s1 As String, cell As Range, j As Long, p1 As String, cell2 As Range, first As Long, second As Long
If Len(s) <> 1 Then
MyCountif = CVErr(xlErrValue)
Exit Function
End If
For Each cell In rng
For i = 1 To Len(cell.Text)
s1 = Mid(cell.Text, i, 1)
If LCase(s1) = LCase(s) Then
If cell.Characters(i, 1).Font.Strikethrough = False Then
numbers(i) = 1
End If
End If
Next
Next
For Each cell2 In rng2
For i = 1 To Len(cell2.Text)
p1 = Mid(cell2.Text, i, 1)
If LCase(p1) = LCase(p) Then
If cell.Characters(i, 1).Font.Strikethrough = False Then
numbers2(i) = 1
End If
End If
Next
Next
For i = 0 To 3
If numbers(i) = 1 And numbers2(i) = 1 Then
MyCountif = MyCountif + 1
End If
Next
End Function
答案 0 :(得分：1)
我想这是南瓜饼！我和@findwindow在一起，我通常不会在写一个OP的整个解决方案的游戏中，因为在原始问题中没有太多证据表明它有一个严重的尝试（可能已经存在，但问题只是一个问题）在细节上有点稀疏，如果是这种情况，请道歉。
无论如何，我一直坐在一个两年不会睡觉的人的最后三个小时......在唱歌摇篮曲之间，威胁父亲的圣诞节不会来，抚摸鼻子，我等解决了这个问题。
我没有时间考虑Excel的CountIf协议用于运算符，例如大于等等，因此最后一块代码只使用CountIf函数。
对于OP，如果您不熟悉VBA，那么您应该知道将单元格格式更改为Strikethrough不会触发重新计算，因此您必须手动命令或者捕获格式变化并强制重新计算（我会让你自己研究一下）。
您可以通过输入Range然后输入值对来调用该函数。例如：=MyCountIfs(A1:A10,">1",C1:C10,"B")。
Public Function MyCountIfs(ParamArray rngCriterionPairs() As Variant) As Variant
'============================================================================================
'Purpose: applies criteria to cells across multiple ranges and aggregates counter for each
' successful match of criterion against cell value in the respective range.
'
'Usage: user must enter one pair of range and criterion values and may enter further
' value pairs in the sequence [range, criterion, range, criterion ...]
'
'Notes: 1. Ranges do not need to be equal in size and do not need to be contiguous.
' 2. Criteria use Excel's CountIf protocol so, for example, ">2" can be used.
' 3. Although this function uses Application.Volatile, changes to cell formats
' won't trigger a recacalculation.
'============================================================================================
Application.Volatile
Dim rangeCriteriaList As Collection 'collection of range/criterion pairs
Dim rcp(1) As Variant 'range/criterion pair
Dim filteredRange As Range 'range object with strikethrough cells removed
Dim workingARange As Boolean 'toggle for testing range-criterion sequence
Dim objTest As Object 'redundant object used for object testing
Dim item As Variant 'variant required to loop through collection
Dim cell As Range 'range object required to loop through cells in range
Dim block As Range 'range object required to loop through areas in range
Dim count As Integer 'aggregates the number of successful hits
Dim i As Integer 'looping variable for paramarray index
'Test the ParamArray paramters
'Must be entered as Range then Variant pairs.
'Excel's CountIfs requires ranges of equal size but we don't need to do that.
'First check parameter has at least two values
If IsEmpty(rngCriterionPairs) Then
MyCountIfs = CVErr(xlErrValue)
Exit Function
End If
If Not IsArray(rngCriterionPairs) Then
MyCountIfs = CVErr(xlErrValue)
Exit Function
End If
'It's an array so loop through the array values
'We'll work through each item and, if it's a Range add it to our rcp(0) variable
'This caters for Ranges separated by commas.
'Once the value isn't a range then it'll be assigned to rcp(1).
'The subsequent value must therefore be a Range and the range test is toggled on/off
'with the workingARange boolean.
Set rangeCriteriaList = New Collection
workingARange = False
For i = 0 To UBound(rngCriterionPairs)
If TypeName(rngCriterionPairs(i)) = "Range" Then
Set filteredRange = NonStrikeThroughCells(rngCriterionPairs(i))
If Not workingARange Then workingARange = True
If Not filteredRange Is Nothing Then
If IsEmpty(rcp(0)) Then 'it's a new range
Set rcp(0) = filteredRange
Else 'it's a non-contiguous range so union with old range
Set rcp(0) = Union(rcp(0), filteredRange)
End If
End If
Else
'It's not a range so workingARange toggle must be set true
If Not workingARange Then
MyCountIfs = CVErr(xlErrValue)
Exit Function
Else
'Toggle the workingARange boolean to false
workingARange = False
'Ignore if the reference range wasn't set
If Not IsEmpty(rcp(0)) Then
'Range then non-range rule is valid, so check the value isn't an object
On Error Resume Next
Set objTest = Nothing: On Error Resume Next
Set objTest = rngCriterionPairs(i): On Error GoTo 0
If Not objTest Is Nothing Then
MyCountIfs = CVErr(xlErrValue)
Exit Function
End If
'It's not an object so we'll use it
rcp(1) = rngCriterionPairs(i)
'Add the range/critrion pair to collection
rangeCriteriaList.Add rcp
'Clear the rcp values
Erase rcp
End If
End If
End If
Next
'Test the last item wasn't a Range
If workingARange Then
MyCountIfs = CVErr(xlErrValue)
Exit Function
End If
'Loop through the collection of ranges and run the count test
'I've used Excel's CountIf function to avoid catering in the code
'for the ">2" type of arguments.
'Purists can have a crack at this within the commented-out block if they wish.
count = 0
For Each item In rangeCriteriaList
For Each block In item(0).Areas
count = count + WorksheetFunction.CountIf(block, item(1))
Next
'For Each cell In item(0).Cells
'If cell.Value = item(1) Then count = count + 1
'Next
Next
'Return the count
MyCountIfs = count
End Function
Private Function NonStrikeThroughCells(rngVar As Variant) As Range
'Removes strikethrough cells from range
Dim rng As Range
Dim cell As Range
Dim result As Range
Set rng = rngVar
For Each cell In rng.Cells
If Not cell.Font.Strikethrough Then
If result Is Nothing Then
Set result = cell
Else
Set result = Union(result, cell)
End If
End If
Next
Set NonStrikeThroughCells = result
End Function
答案 1 :(得分：0)
您可以简化函数以返回TRUE / FALSE数组，并在简单数组SUM函数中使用它来执行其他条件而不是使VBA过于复杂
Public Function HasStrikeThrough(rng As Range) As Variant
Dim cell As Range
Dim idx As Long
Dim i As Long
Dim ary As Variant
Application.Volatile
ReDim ary(1 To rng.Cells.Count)
For Each cell In rng
idx = idx + 1
ary(idx) = False
For i = 1 To Len(cell.Text)
If cell.Characters(i, 1).Font.Strikethrough Then ary(idx) = True
Next
Next
HasStrikeThrough = Application.Transpose(ary)
End Function
并且您的工作表公式将是这样的
=SUM((B1:B10="a")*(C1:C10="y")*(HasStrikeThrough(D1:D10)))