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

Filter a PivotChart with Dates
Combobox drop down showing up in other sheets
Excel Marco set range.address
Excel VBA to update only one cell at one time
Excel VBA - Refer to a worksheet as a variable in an IF statement
Excel Formula to Lookup multiple columns
VBA: unable to get a range from search
Searching occurrence of custom codes in data set
Custom Eval function in excel
Implementing a status bar window in VBA Excel script
Copy, Paste & Sort non-defined ranges “Object variable or With block variable not set”
trying use excel to count how many times a doctor is on a rotation in a month
VBA run from my PERSONAL wb is perfect, copied to a distro wb and it breaks. Why?
Excel formatting without VBA
Identify it then Move It (Macro)
VBA Excel. Code will not search subfolders [duplicate]

Categories

HOME
firmware
statistics
freeswitch
zurb-foundation
binary
mariadb
mips32
quandl
windows-authentication
rhel
benchmarking
category
twitter-typeahead
bit-manipulation
accurev
bootstrap-select
image-comparison
mysql-error-1064
premailer
pki
xfce
cropper
na
side-effects
tensorflow-serving
gulp-4
opensaml
hashcode
nn
webmin
gooddata
shieldui
960.gs
gulp-usemin
singleton-type
gold-parser
yield
xc8
tableau-public
sp-executesql
doubly-linked-list
nosuchelementexception
erwin
greenlets
nslog
jwrapper
raptor
nested-attributes
kendo-datepicker
anthill
struts2-jquery-grid
polymer-designer-tool
johnny-five
fedora-commons
mpmediapickercontroller
soundex
mashape
dynamicquery
kismet-wireless
coderunner
dcraw
zenoss
chap-links-library
ilias
editplus
stackato
jsqlparser
knockout-mapping-plugin
dav
cxf-client
webproxy
android-x86
microsoft-search-server
interlacing
statamic
server-side-scripting
jwebunit
trusted-timestamp
operational-transform
strtotime
nservicebus3
converters
static-array
customer-support
primefaces-extensions
getprocaddress
mono-service
umbraco5
visualtreehelper
cloning
raw-ethernet
ipod-nano
projective-geometry

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