### excel

#### Create a countIfs function that ignores cells with text that has been struck through

Searching through the internet I was able to find some code that creates a countIf function that will not count a cell if there is strikethrough text in it. 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 I was wondering if it was possible to make a similar function but instead in the form of a countIfs function that can also ignore the strikethrough text. Edit: I don't have a ton of vba experience but I did give it a try myself. Since what I need it for will only need two ranges and two criteria I tried to put together something that ran the original function twice and if both criteria were met it would raise the count by one but I haven't quite gotten it to work. 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

I guess here's the pumkin pie! I'm with #findwindow in that I'm not normally in the game of writing an OP's entire solution when there isn't much evidence in the original question of a serious attempt at it (perhaps there has been but the question is just a bit sparse on detail, so apologies if that is the case). Anyhow, I've been sitting next to a two-year who just won't sleep for the last three hours ... and in between bouts of singing lullabies, threatening father Christmas won't come, stroking a nose, etc., etc. I had a crack at solving this problem. I didn't have time to think about Excel's CountIf protocol for operators such as greater than, etc., so the last chunk of code just uses the CountIf function. To the OP, if you're not that familiar with VBA then you should be aware that changing the format of cells to Strikethrough won't trigger a recalculation, so you'll either have to command that manually or capture the format change and force a recalculation (I'll let you research that bit for yourself). You call the function by entering Range then value pairs. For example: =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

You could simplify your function to return an array of TRUE/FALSE, and use that in a simple array SUM function to do the other conditions rather than over-complicate your 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 and your worksheet formula would be like this =SUM((B1:B10="a")*(C1:C10="y")*(HasStrikeThrough(D1:D10)))

### Related Links

VBA: saving to specific path based on cell values

how to extract only specific strings in VBA

Excel VBA: Communicating via named pipe

macro inserts the word TRUE in cell

Output difference of two columns excel with exclusion criteria

Excel VBA code reads wrong innerHTML code

Get the length of decimal places

Excel Formula to copy cell value to a column based on condition

Excel Webservice Function Yahoo Finance

Using a dynamic cell value in excel VBA

Excel VBA gives type mismatch on dividing decimal numbers after split

Get data from a website table to the excel sheet

VBA Set Dropdown value

VBA Access to Excel export, Error 1004 and 70 when re-running the script

Excel 2010 if condition occurs in column

Do Until loop gives Unknown Runtime Error in VBScript