Archive for the ‘Arrays’ Category.

Efficient Looping

In a previous post, I demonstrated how to use constants to improve your code. Then everyone started beating up my loop. The code wasn't solving a real life problem, so I just threw any old loop together. It wasn't relevant because that's not what the post was about. To fight back, I created a highly improbably backstory in the comments to make my loop look at least as efficient as everyone else's.

But no matter how crazy my story was, I couldn't subvert Peltier's comment about reading the range into an array. So I tried to see what kind of time differences we're talking about. I wrote this code:

Sub DoBoth()
   
    Dim lStart As Long
    Dim i As Long
   
    lStart = Timer
        For i = 1 To 10
            FindTotals2
        Next i
    Debug.Print Timer - lStart
    lStart = Timer
        For i = 1 To 10
            UseArray
        Next i
    Debug.Print Timer - lStart
   
End Sub
 
Sub FindTotals2()
   
    Dim rCell As Range
   
    Const sFIND As String = "Total"
   
    For Each rCell In Sheet1.Columns(1).Cells
        If Left$(rCell, Len(sFIND)) = sFIND Then
            'Do something
        End If
    Next rCell
   
End Sub
 
Sub UseArray()
   
    Dim vArr As Variant
    Dim i As Long
   
    Const sFIND As String = "Total"
   
    vArr = Sheet1.Columns(1).Value
   
    For i = LBound(vArr) To UBound(vArr)
        If Left$(vArr(i, 1), Len(sFIND)) = sFIND Then
            'Do something
        End If
    Next i
   
End Sub

And got these results:

The array is quite a bit faster. I don't think Timer is hyper-accurate, but relatively the differences are pretty clear.

Parsing the Bible

An AOL-user asks J-Walk:

An AOL User: What five letter word appears in the KJV only four times? It was made before Adam and named by Adam. Had no legs, arms or soul. Was given a soul and it was taken back.

Using J-Walk's Bible in Excel, I listed all of the five letter words that appear only four times. Here's the code:

Sub FindWord()
   
    Dim sh As Worksheet
    Dim rCell As Range
    Dim colWords As Collection
    Dim vaWords As Variant
    Dim i As Long
    Dim sText As String
    Dim vaRemove As Variant
   
    Const lLEN As Long = 5
    Const lFREQ As Long = 4
   
    Set colWords = New Collection
   
    vaRemove = Array(",", ".", ":", ";", "!", "?", "(", ")")
   
    For Each sh In ThisWorkbook.Worksheets
        For Each rCell In Intersect(sh.Columns(2), sh.UsedRange).Cells
            sText = rCell.Text
            For i = LBound(vaRemove) To UBound(vaRemove)
                sText = Replace(sText, vaRemove(i), "")
            Next i
            vaWords = Split(sText, " ")
            For i = LBound(vaWords) To UBound(vaWords)
                If Len(vaWords(i)) = lLEN Then
                    On Error Resume Next
                        colWords.Add vaWords(i), CStr(vaWords(i))
                    On Error GoTo 0
                End If
            Next i
        Next rCell
    Next sh
   
    For i = 1 To colWords.Count
        Sheet1.Range("G2").Value = colWords(i)
        If Application.WorksheetFunction.Sum(Sheet1.Range("G5:G70")) = lFREQ Then
            Debug.Print colWords(i)
        End If
    Next i
   
End Sub

It uses the "Stats" page in the workbook to compute the number of times each word appears. This is not a good way to do it, because each word causes an expensive recalc. But I didn't want to spend time writing my own algorithm. I started the macro and came back 20 minutes later.

Creating Wildcards

I need to save the names of one or more files in the custom document properties of a workbook. I don't want to create a separate property for every filename. I thought about saving a comma-delimited string, then parsing it out. It would look like:

file1name,file2name

Another idea I had was just save one string that could stand for both:

file?name

I need to convert a number of strings into one string with the appropriate wildcards. I came up with the code below, but it has some shortcomings. It replaces differing characters in the same position with a question mark, and converts strings of three question marks or more into an asterisk. That means for wildcards("consistent","inconsistent"), it returns *s* when I would prefer it return *consistent.

Any suggestions on making it better?

Function Wildcards(ParamArray vaText() As Variant) As String
   
    Dim i As Long, j As Long
    Dim sShort As String, sLong As String
    Dim sTemp As String
   
    Const sQUES As String = "?"
    Const sASTR As String = "*"
       
    'If only one string, then return it
    If LBound(vaText) = UBound(vaText) Then
        Wildcards = vaText(LBound(vaText))
    Else
        sShort = vaText(LBound(vaText))
       
        'Store the longest and shortest strings
        For i = LBound(vaText) To UBound(vaText)
            If Len(vaText(i)) <Len(sShort) Then
                sShort = vaText(i)
            End If
            If Len(vaText(i))> Len(sLong) Then
                sLong = vaText(i)
            End If
        Next i
       
        sTemp = sShort
       
        'replace differing chars with ?
        For i = LBound(vaText) To UBound(vaText)
            If vaText(i) <> sShort Then
                For j = 1 To Len(sShort)
                    If Mid(vaText(i), j, 1) <> Mid(sTemp, j, 1) Then
                        sTemp = Left(sTemp, j - 1) & sQUES & Mid(sTemp, j + 1, Len(sTemp))
                    End If
                Next j
            End If
        Next i
       
        'pad ?s to the end of the longest string
        sTemp = sTemp & String(Len(sLong) - Len(sShort), sQUES)
       
        'replace three or more ?s with a *
        If Len(sLong)>= 3 Then
            For i = Len(sLong) To 3 Step -1
                sTemp = Replace(sTemp, String(i, sQUES), sASTR)
            Next i
        End If
               
        Wildcards = sTemp
    End If
   
End Function

Caller and Custom Commandbars

I learned some things today. Apparently I've never used Application.Caller in a procedure called from a custom CommandBarButton. Or if I have, and have since forgot about it. As it turns out, Application.Caller returns a Variant array with two elements. The first element seems like it should be the index number of the CommandBarButton from which the procedure was called. That is, if the second button on the CommandBar runs the procedure, the first element would contain a 2. The second element contains string that is the Caption of the CommandBar.

I say "seems" when I refer to the first element, because my CommandBar only contains four buttons.

?CommandBars("BBash").Controls.Count
4

Yet the first element of Application.Caller returns a seven. All of the controls are CommandBarButtons. There are no popups or any other kind of control. I can't imagine where it's getting 7. Does anyone know what I'm missing here?

If you're as surprised as I am that I didn't know Application.Caller returned an array, then you may be equally surprised at lesson #2 of the day. I can use a For Each construct to access the elements of an array as long as the control variable is Variant. I've always looped through arrays with For Next constructs like this

For x = LBound(arr) To UBound(arr)
    Debug.Print arr(x)
Next x

Now I know I could use this

For Each x In arr
    Debug.Print x
Next x

as long as x is declared as a Variant. I don't really plan to use this as it seems like an unnecessary use of a Variant.

Finally, an old nugget that I just don't use enough: multiple statements in the Immediate Window. In VBA procedures, you can put multiple statements on the same line by separating them with a colon. Since statements in the Immediate Window are executed as soon as you enter them, it's sometimes necessary to employ this technique. When I was trying to figure out what in tarnation Application.Caller was doing, I used a loop in the Immediate Window. To wit:

If you didn't know you could loop in the Immediate Window, then maybe you learned something today too.

Transposing the Formulas in a Table of Cells

OK, time for some non Excel 2007 stuff...

Recently someone asked me if it was possible to transpose a table of cells, but in such a way that the formula of each cell is kept intact. I decided VBA was the way to go and produced a small but very useful little routine for that.

What the poster wanted is to go from:

To:

Read on here.

Regards,

Jan Karel Pieterse

JKP Application Development Services

Founding member of:
Professional Office Developers Association

Sorting Arrays of User Defined Types

I have an array of user defined types. The type has three elements and I need to sort on all three. Surprisingly, I've never had to sort an array of udt's before. Here's how I did it:

Type MyInfo
    lType As Long
    sName As String
    dStart As Date
End Type
 
Sub Start()
   
    Dim aInfo(0 To 4) As MyInfo
    Dim i As Long
    Dim vaTypes As Variant
    Dim vaNames As Variant
    Dim vaDates As Variant
   
    'fill the array with some unsorted data
    vaTypes = Array(2, 1, 1, 2, 1)
    vaNames = Array("Joe", "Bob", "Bob", "Joe", "Joe")
    vaDates = Array(#1/1/2006#, #2/1/2006#, #1/15/2006#, #6/30/2005#, #1/8/2006#)
   
    For i = 0 To 4
        aInfo(i).lType = vaTypes(i)
        aInfo(i).sName = vaNames(i)
        aInfo(i).dStart = vaDates(i)
    Next i
   
    'call the sort procedure
    SortInfo aInfo
   
    'output the results to the immediate window
    For i = LBound(aInfo) To UBound(aInfo)
        Debug.Print aInfo(i).lType, aInfo(i).sName, aInfo(i).dStart
    Next i
   
End Sub
 
Sub SortInfo(ByRef aInfo() As MyInfo)
   
    Dim i As Long, j As Long
    Dim tTemp As MyInfo
   
    'standard bubble sort loops
    For i = LBound(aInfo) To UBound(aInfo) - 1
        For j = i To UBound(aInfo)
            'sort on the first element
            If aInfo(i).lType> aInfo(j).lType Then
           
                SwapInfo aInfo, i, j
           
            'if the first element is the same, sort on the second
            ElseIf aInfo(i).lType = aInfo(j).lType And _
                aInfo(i).sName> aInfo(j).sName Then
               
                SwapInfo aInfo, i, j
           
            'if the first two elements are the same, sort on the third
            ElseIf aInfo(i).lType = aInfo(j).lType And _
                aInfo(i).sName = aInfo(j).sName And _
                aInfo(i).dStart> aInfo(j).dStart Then
               
                SwapInfo aInfo, i, j
               
            End If
        Next j
    Next i
   
End Sub
 
Sub SwapInfo(ByRef aInfo() As MyInfo, ByVal lOne As Long, ByVal lTwo As Long)
 
    Dim tTemp As MyInfo
   
    tTemp = aInfo(lOne)
    aInfo(lOne) = aInfo(lTwo)
    aInfo(lTwo) = tTemp
   
End Sub

immediate window showing sorted output

Is there an easier way?