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

Categories

HOME
angular
recaptcha
.net-core
dropbox-api
automation
netlogo
datatable
etcd
linuxmint
axis2
directshow
sage
chapel
amazon-cloudsearch
visio
shoutem
zk
firebreath
riscv
netbeans-7.3
sprite
spring-statemachine
multiline
xlwings
deprecation-warning
silex
indexoutofrangeexception
ebcdic
cropper
provider
inversifyjs
pdb-files
jquery-ui-autocomplete
ipc
hp-quality-center
ecore
javabeans
pam
gperftools
leanft
webdrivermanager-java
webmin
interactive
smtpclient
dataweave
nonetype
singleton-type
sw-precache
react-d3
fluentbootstrap
showdown
webpack-style-loader
vqmod
google-api-v3
audio-player
suppress-warnings
imshow
dex2oat
nested-attributes
onbeforeunload
agile-project-management
ienumerable
throttle
classname
testdroid
openoffice-writer
wns
nscoding
oracle-streams
ibm-jazz
blackberry-simulator
episerver-6-r2
johnny-five
nameerror
apache-commons
gstat
unique-constraint
akeneo
savefiledialog
certificatestore
gamma-function
er-diagrams
allocation
orchardcms-1.6
rgs
uploadifive
iec61131-3
curator
linux-capabilities
ember-qunit
ransac
pegjs
tracker
subsonic2.2
option
nools
form-helpers
httpwatch
sandbox-solution
iron
freetextbox
dynamic-html
google-email-settings-api
harfbuzz
jbossws
panning
ereg
strtotime
enctype
nexus-7
python-sockets
endl
mindmapping
juggernaut
nscoder
abbreviation
maintenance-plan
trackback

Resources

Mobile Apps Dev
Database Users
javascript
java
csharp
php
android
MS Developer
developer works
python
ios
c
html
jquery
RDBMS discuss
Cloud Virtualization
Database Dev&Adm
javascript
java
csharp
php
python
android
jquery
ruby
ios
html
Mobile App
Mobile App
Mobile App