[VBA] Something like COUNTIFS for Excel 2003

Well, there you go. A colleague sends you a copy of an Excel file and needs a nice formula. So I do the nice formula. Then I try to save the sheet back into the same form in which it arrived:

Clang!

Seems that Excel 2003 doesn't have the nice little COUNTIFS function that I have in my Excel 2007. What to do, what to do, what to do ...

Well, it'd be nice to install Office 07, but in the interim, how about a bit of VBA?

We'll call it RANGEDCOUNT, and it will accept a range of data, and a string being the criteria. The criteria can be

1. a single value preceded by an operation (>, >=, =, <=, <, #), or


2. a range of values, the upper and lower bounds separated by a dash.

Function RANGEDCOUNT(rData As Range, rCriteria As String) As Integer
        Dim i As Long
        Dim sOper As String
        Dim dAmt As Double
        Dim dUpper As Double
        Dim dLower As Double
        Dim bRanged As Boolean
        Dim iDash As Integer
        Dim dDataItem As Double
        Dim iCount As Integer
        iCount = 0
        bRanged = False

Right, that's all the declarations over with. Now to check whether we have a range specification or not and what to do if it's not. Notice the 'Instr(2' which checks for an equals sign after the first character, as we're checking to see if we have '>=' or '<=' and don't want to fail on a bare equals

        iDash = InStr(1, rCriteria, "-")
        If iDash = 0 Then
                If InStr(2, rCriteria, "=") Then
                        sOper = Left$(rCriteria, 2)
                        dAmt = Val(Mid$(rCriteria, 3))
                Else
                        sOper = Left$(rCriteria, 1)
                        dAmt = Val(Mid$(rCriteria, 2))
                End If

The else fires if we do in fact have a range setting and handles that appropriately.

        Else
                bRanged = True
                dLower = Val(Left$(rCriteria, iDash - 1))
                dUpper = Val(Mid$(rCriteria, iDash + 1))
        End If

Next, step through the data and for each element, apply the logic for either a ranged count or an operator count.

        For i = 1 To rData.Count '- 1 'LBound(rData.) To UBound(rData)
                dDataItem = rData(i).Value
                If bRanged Then
                        If dDataItem >= dLower And dDataItem <= dUpper Then
                                iCount = iCount + 1
                        End If
                Else
                        Select Case sOper
                        Case "="
                                If dDataItem = dAmt Then iCount = iCount + 1
                        Case "<"
                                If dDataItem < dAmt Then iCount = iCount + 1
                        Case ">"
                                If dDataItem > dAmt Then iCount = iCount + 1
                        Case "<="
                                If dDataItem <= dAmt Then iCount = iCount + 1
                        Case ">="
                                If dDataItem >= dAmt Then iCount = iCount + 1
                        Case "#"
                                If dDataItem <> dAmt Then iCount = iCount + 1
                        End Select
                End If
        Next

Okay, iCount should have the result, so put it in RANGEDCOUNT and end.

        RANGEDCOUNT = iCount
End Function

Not bad for 15 to 20 minutes work, and would've been faster if I'd remembered how to get data out of Ranges. Now my colleague is happier and I've had a chance to do some something interesting. Granted, it's not particularly fault tolerant, but it's enough for now. © Bruce M. Axtens, 2010

[VB6]Searching an ActiveX/COM object for a method

This article was first posted by me on StackOverflow in response to my own question, "How do I search an ActiveX/COM object for a method?". This article is an edited version of the original.

"After Googling around not quite finding what I wanted, I remembered the Edanmo site which got me thinking about TLBINF32.DLL, downloading Microsoft's TLBINF32.CHM and reading up on GetMembersWithSubStringEx.

Below is the implementation of it (done in VB6 with a reference to TLBINF32.DLL), some demo VBScript and output, and the wrapping of that functionality in some VBA.

Public Function SearchTLIMethodsAndProperties(sTypelib As Variant, sSymbol As Variant) As Variant Dim SI As SearchItem Dim aResults As Variant Dim bFound as boolean Dim Groups(1) As InvokeKinds Groups(0) = INVOKE_FUNC Or INVOKE_PROPERTYGET Or _ INVOKE_PROPERTYPUT Or INVOKE_PROPERTYPUTREF ReDim aResults(0) bFound = False With TypeLibInfoFromFile(sTypelib) .SearchDefault = tliStClasses Or tliStEvents For Each SI In .GetMembersWithSubStringEx(sSymbol, Groups) bFound = True arr.AAdd_PostIncrement aResults, SI.Name Next End With if bFound then ReDim Preserve aResults(UBound(aResults) - 1) end if SearchTLIMethodsAndProperties = aResults End Function

VBScript demo. The above code was included in my StdLib DLL in the Registry coclass.

Dim O, R Set O = CreateObject("Std.Registry") Set R = CreateObject("Std.Arrays") WScript.Echo R.ShowStructure( O.SearchTLIMethodsAndProperties( "MSSCRIPT.OCX",""))

Output from the demo (script was run in SciTE).

>cscript "C:\foo\foo.vbs" {Add,AddCode,AddObject,AllowUI,Clear,CodeObject,Column,Count,Description,Error,Eval,ExecuteStatement,HasReturnValue,HelpContext,HelpFile,Item,Language,Line,Modules,Name,NumArgs,Number,Procedures,Reset,Run,SitehWnd,Source,State,Text,Timeout,UseSafeSubset} >Exit code: 0

Finally, the VBA code. A cell has a symbol in it and this routine finds it or returns an error string. (reg. in this case refers to the Registry coclass in the StdLib.DLL)

Public Function LookupSymbol(sLib As String, sSym As String) As String Dim aRes As Variant aRes = reg.SearchTLIMethodsAndProperties(sLib, sSym) Dim i As Integer LookupSymbol = "!!NotFound!!" For i = 0 To UBound(aRes) If LCase$(aRes(i)) = LCase$(sSym) Then LookupSymbol = sSym Exit For End If Next End Function

Hmm ... no error checking. Should fix that.

© Copyright Bruce M. Axtens, 2009