Archive for the ‘Arrays’ Category.
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.
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.
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
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.
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
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
Is there an easier way?