Daily Dose of Excel

Euler Problem 102

Michael — Sun, 04 Jan 2009 20:44:55 +0000

Euler Problem 102 asks:

'Three distinct points are plotted at random on a Cartesian plane, for which
'-1000 LTE x, y LTE 1000, such that a triangle is formed.
'
'Consider the following two triangles:
'
'A(-340,495), B(-153,-910), C(835,-947)
'
'X(-175,41), Y(-421,-714), Z(574,-645)
'
'It can be verified that triangle ABC contains the origin, whereas
'triangle XYZ does not.
'
'Using triangles.txt (right click and 'Save Link/Target As...'), a 27K text
'file containing the co-ordinates of one thousand "random" triangles, find
'the number of triangles for which the interior contains the origin.
'
'NOTE: The first two examples in the file represent the triangles in the
'example given above.

In the above, LTE is "less than or equal", to outsmart the html bugs.

Any triangle that has all-positive x-coordinates, or all-negative x-coordinates, or similarly all-positive or all-negative y-coordinates, can not contain the origin. A pre-screen will throw all those out. When I first solved this problem, I looked for triangles with both a positive and a negative y-intercept, coupled with both a positive and negative x-intercept, and counted those triangles. That was a successful strategy. LINEST() will return x-intercepts it you swap known-xs and known-ys in the formula. The code looked like this:

YIntercept(3, 1) = Application.WorksheetFunction.Index( _
Application.WorksheetFunction.LinEst(Known_Ys, Known_Xs), 2)

XIntercept(3, 1) = Application.WorksheetFunction.Index( _
Application.WorksheetFunction.LinEst(Known_Xs, Known_Ys), 2)

It's right out of the Help for LINEST(), or at least the y-intercept part is. However, after I checked my answer in I read another strategy that was just so flat-out neat that I coded it up. It uses Heron's Law which calculates the area of a triangle based on a calculation of the semi-perimeter, or 1/2 the sum of the sides: The area of a triangle, given the lengths a,b,c of the sides, is A = sqrt s*(s-a)*(s-b)*(s-c), where s is the semiperimeter 0.5*(a+b+c). If we calculate the area of the suspect triangle, and then the area of the three sub-triangles with a common vertex of the origin, if the sum of the sub-triangle areas equals the area of the whole, then the origin must be within the suspect triangle. That code looked like this:

Option Explicit
Option Base 1
Sub Problem_102B()
Dim Triangle(1000) As Variant
Dim i As Long
Dim j As Long
Dim Most As Long
Dim Impossible As Boolean
Dim IsTest As Boolean
Dim x(3) As Long 'X Coordinates
Dim Y(3) As Long 'Y Coordinates
Dim d(3) As Double 'Distance between points
Dim O(3) As Double 'Distance from points to (0,0)
Dim Area As Double 'Triangle area
Dim a(3) As Double 'Sub-triangle area
Dim T As Single
Dim Answer As Long
Const text As String = "D:\Downloads\Euler\triangles.txt"

T = Timer
IsTest = False
If IsTest Then
Most = 2
Else
Most = 1000
End If

i = 1
Open text For Input As #1 '1000 lines, comma delimited
Do While Not EOF(1)
Line Input #1, Triangle(i)
Triangle(i) = Split(Triangle(i), ",") 'zero-based array
i = i + 1
Loop
Close #1

For i = 1 To Most
Impossible = False

x(1) = Triangle(i)(0) 'zero-based array
Y(1) = Triangle(i)(1)
x(2) = Triangle(i)(2)
Y(2) = Triangle(i)(3)
x(3) = Triangle(i)(4)
Y(3) = Triangle(i)(5)

'For Triangles all above or all below the X-axis
If Y(1)> 0 And Y(2)> 0 And Y(3)> 0 Then Impossible = True
If Y(1) <0 And Y(2) <0 And Y(3) <0 Then Impossible = True
'For Triangles all to left of or all to right of the Y-axis
If Not Impossible Then 'yet
If x(1)> 0 And x(2)> 0 And x(3)> 0 Then Impossible = True
If x(1) <0 And x(2) <0 And x(3) <0 Then Impossible = True
End If

If Impossible Then GoTo Next_i

d(1) = TriSides(CDbl(x(1) - x(2)), CDbl(Y(1) - Y(2)))
d(2) = TriSides(CDbl(x(2) - x(3)), CDbl(Y(2) - Y(3)))
d(3) = TriSides(CDbl(x(1) - x(3)), CDbl(Y(1) - Y(3)))
Area = Heron(d(1), d(2), d(3))

O(1) = TriSides(CDbl(x(1)), CDbl(Y(1)))
O(2) = TriSides(CDbl(x(2)), CDbl(Y(2)))
O(3) = TriSides(CDbl(x(3)), CDbl(Y(3)))
a(1) = Heron(d(1), O(1), O(2))
a(2) = Heron(d(2), O(2), O(3))
a(3) = Heron(d(3), O(1), O(3))

If CSng(Area) = CSng(a(1) + a(2) + a(3)) Then
Answer = Answer + 1
End If

Next_i:
Next i

Debug.Print Answer; " Time:"; Timer - T
End Sub

Those are the escape code for > and < . Can't figure out how to get it right inside the vb blocks. We can escape it outside, but we truncate if we use the angle brackets, and don't render the brackets right if we escape. It's been a conundrum for a while.

I used two functions, TriSides(), which returns the square root of the sum or difference of two squares, so I could do Pythagorean math, and Heron(), which implements Heron's law:

Function TriSides(a As Double, b As Double, Optional Sum)
If IsMissing(Sum) Then Sum = True
If Sum Then
TriSides = Sqr(a ^ 2 + b ^ 2)
Else
TriSides = Sqr(Abs(a ^ 2 - b ^ 2)) ' order doesn't matter
End If
End Function

Function Heron(a As Double, b As Double, C As Double) As Double
'Use Heron 's formula for the area of a triangle
'given the lengths a,b,c of the sides
'A = sqrt s*(s-a)*(s-b)*(s-c)
'where s is the semiperimeter 0.5*(a+b+c).

Dim s As Double
s = 0.5 * (a + b + C)
Heron = Sqr(s * (s - a) * (s - b) * (s - C))
End Function

I admire those who saw the application of Heron going in. One thing that I don't understand is why I had to convert doubles to singles at the end for the areas to total per Heron. I presume is has to do with the square root routine, but I invite comment. Code ran in one-tenth the time of 102A, at about .01 seconds.

...mrt

Recursion as a performance boost!

Tushar Mehta — Sat, 03 Jan 2009 05:58:46 +0000

A common misconception some (many?) have about recursive solutions is that they are not fast. There are many reasons to use recursion, both in code and in data, mainly that solutions based on recursion are easy to implement, understand, and maintain. For an introduction see Recursion (http://www.tushar-mehta.com/publish_train/book_vba/07_recursion.htm).

What is interesting is that recursive solutions can also provide an improvement over a non-recursive solution. This happened recently when I finally decided to tackle Project Euler problem 14 (http://projecteuler.net/index.php?section=problems&id=14). In the problem, one had to find the number under 1,000,000 that had the longest Collatz chain.

I had postponed addressing the problem because until earlier today I could think of only a "brute force" approach¹. But, then, I realized something. If one started from 1 and worked their way up to 999,999, one could build a database of answers for all the numbers encountered in earlier calculations. Then, whenever one encountered a number already in the database, a simple look up of the associated would short circuit the need for any further computations.

For the recursive implementation as well as the intuitive approach see Project Euler - Problem 14 (http://www.tushar-mehta.com/misc_tutorials/project_euler/euler014.html)

¹ A approach that should work but that I consider as somewhat unethical is to assume that the solution is a high number. So, work backwards from 999,999 to 900,000. Check this solution with the Project Euler system. If it rejects your answer, try the range 899,999 to 800,000. If that isn't OK, try the next range down. Sooner or later you will find the correct answer. Just keep in mind that the PE website has a 20 minute wait before one can resubmit an answer.

Euler Problem 22

Michael — Fri, 02 Jan 2009 23:30:08 +0000

Euler Problem 22 asks:

'Using names.txt (right click and 'Save Link/Target As...'), a 46K text file containing over
'five-thousand first names, begin by sorting it into alphabetical order. Then working out the
'alphabetical value for each name, multiply this value by its alphabetical position in the list
'to obtain a name score.

'For example, when the list is sorted into alphabetical order, COLIN, which is worth
'3 + 15 + 12 + 9 + 14 = 53, is the 938th name in the list. So, COLIN would obtain a score of
'938 * 53 = 49714.

'What is the total of all the name scores in the file?

The general task is to time the calculation.
The specific tasks are:

Open the file
Clean it up (it's one long line of data, with names wrapped in quotes, and comma-delimited, as in ...,"COLIN",...)
Sort the names
Determine each name's alphabetical value
Multiply the position by the value
Sum the scores

Here is my code:

Option Explicit
Sub Problem_022()
Dim NameArray As Variant
Dim TEMP As String
Dim T As Single
Dim i As Long
Dim j As Long
Dim Score As Long
Dim Answer As Long
Const namestext As String = "D:\Downloads\Euler\names.txt"

T = Timer 'start timing
Open namestext For Input As #1 ' open the file
Do While Not EOF(1)
Line Input #1, TEMP
Loop
Close #1
TEMP = VBA.Replace(TEMP, Chr(34), vbNullString) 'strip quotes -- chr(34)

NameArray = Split(TEMP, ",") 'TEMP a comma delimited file, split on the comma
'creating an array to sort
'BubbleSort
For i = LBound(NameArray) To UBound(NameArray) - 1
For j = i To UBound(NameArray)
If NameArray(i)> NameArray(j) Then
TEMP = NameArray(j)
NameArray(j) = NameArray(i)
NameArray(i) = TEMP
End If
Next j
Next i

For i = LBound(NameArray) To UBound(NameArray)
Score = LexValue(CStr(NameArray(i))) 'computes the alphabetic value
Answer = Answer + (Score * (i + 1)) ' NameArray is zero-based
'multiplies and sums
Score = 0
Next i

Debug.Print Answer; " Time:"; Timer - T

End Sub

NameArray is zero-based. Euler's names aren't. The first name has position 1. We need to offset by 1.
The alphabetic value is just the sum of the ascii codes (offset by 64, so "A" gets 1) for each letter. This little function does that. It'll be used in other Euler problems.

Function LexValue(Word As String) As Long
Dim i As Long
For i = 1 To Len(Word)
LexValue = LexValue + (Asc(Mid(Word, i, 1)) - 64)
Next i
End Function

This runs in 15 seconds
...mrt

Bubble Sorts

Michael — Fri, 02 Jan 2009 23:01:44 +0000

Two problems so far, Eulers 22 and 29, have required sorts, at least for my implementations. Euler 22 sorts over 5000 name strings, and Euler 29 sorts nearly 10,000 numerics. In both cases I used a bubble sort. Bubble sorts get their name from the image of the greater-valued item "bubbling up" to its place in line.

Bubble sorts have some advantages and disadvantages. The BIG disadvantage is that no matter how nearly-sorted the list is at start, you will still go through it (n-1)^2 times, n being the number of items. The advantages of bubble sorts are:

They're easy to code. Typically just nine lines. And
To make a descending sort, you reverse just one inequality

To do a bubble sort, you need three things:

An indexed list or array with a sortable value or property
Explicit or implicit knowledge of the count or quantity of items to sort. You may know the count (n) because you set it, or the computer knows it via Item.count or UBound(Item), for example
A TEMP variable of the same type as being sorted, often also called SWAP

If you think of sorting a deck of cards, the outer loop sorts cards from 1 to 51, and the inner loop compares those values with cards from 2 to 52. With fast computers, bubble sorts are probably "fast enough." Both problems for me took less than 20 seconds.

This is my implementation of a bubble sort. You'll see it used in the next post, on Euler 22.

Sub BubbleItUp() 'an ascending sort

Const n As Long = 5
Dim i As Long
Dim j As Long
Dim Char(n) As String * 1
Dim TEMP As String * 1

For i = 1 To n
Char(i) = CStr(n + 1 - i)
Next i

Debug.Print Char(1); Char(2); Char(3); Char(4); Char(5)
For i = 1 To n - 1
For j = i + 1 To n
If Char(i)> Char(j) Then 'flip the inequality for a descending sort
TEMP = Char(j)
Char(j) = Char(i)
Char(i) = TEMP
End If
Next j
Debug.Print Char(1); Char(2); Char(3); Char(4); Char(5)
Next i

End Sub

...mrt

Excel Sample Data

Dick Kusleika — Thu, 01 Jan 2009 16:26:48 +0000

I love finding big Excel tables, mostly because I hate manually creating sample data for testing. I've written about Contextures Sample Data. Then there's the IRS Tax Statistics page that has many downloadable Excel files. The IRS tables aren't always clean tables. Sometimes they are over-formatted, but they still work.

My latest find was a couple of tables used in the book Irrational Exuberance. Robert Shiller says:

# One can access an Excel file with the data set (used and described in the book) on stock prices, earnings, dividends and interest rates since 1871, updated.
# One can access an Excel file with the data set (used and described in the book) on home prices, building costs, population and interest rates since 1890, updated.

I haven't read the book, but it sounds interesting.

I Resolve

Dick Kusleika — Wed, 31 Dec 2008 19:31:50 +0000

For 2009, I resolve to stop keeping detailed track of my time at work. It started as a small experiment to see where I was spending my time. There weren't any real surprises in the data. I guess one surprise was how easy it was to use the tool I built to keep track. So easy, in fact, that I just kept on recording my time. Until today, that is. Here's how I've spent the last four months.

I further resolve to make this tool a proper add-in. I'll be taking J-Walk's advice and storing the data in a csv file and some other suggestions I got about it. I'll add some simple reporting options for pulling the data into Excel. And menus, ribbons, what-have-you. Then sell it. I'm thinking free for personal use and $20 for commercial use. Do you think anyone would buy it?

Euler Problem 19

Michael — Wed, 31 Dec 2008 03:06:37 +0000

Euler Problem 19 asks:

'You are given the following information, but you may prefer to do some
'research for yourself.
'
' * 1 Jan 1900 was a Monday.
' * Thirty days has September,
' April, June and November.
' All the rest have thirty-one,
' Saving February alone,
' Which has twenty-eight, rain or shine.
' And on leap years, twenty-nine.
' * A leap year occurs on any year evenly divisible by 4, but not on a
'century unless it is divisible by 400.
'
'How many Sundays fell on the first of the month during the twentieth
'century (1 Jan 1901 to 31 Dec 2000)?

Wow. First thought: Euler actually got the century right. Math-minded indeed. Second thought: I need a day counter, a week counter, a month counter, a leap year checker. That's a lot of conditionals. No wonder this is here. Third thought: I'm doing this in Excel. Piece of cake. This may be the only one aimed right at us, if not intentionally. Here's my code. Ran in under a second.

Sub Problem_019()
Dim Start As Date
Dim Answer As Long
Dim T As Single

T = Timer
Start = DateSerial(1901, 1, 1)

Do While Start < DateSerial(2001, 1, 1)
If Weekday(Start) = vbSunday And Day(Start) = vbSunday Then
Answer = Answer + 1
End If
Start = Start + 1
Loop

Debug.Print Answer; " Time:", Timer - T

End Sub

Coded it up. It ran the first time, and I checked in with the right answer. I was feeling so good until I saw the pencil and paper approach of those who'd solved it ...100 years with 12 months per year over 7 days

...mrt

Euler Problem 55

Michael — Wed, 31 Dec 2008 01:34:10 +0000

Problem 55 asks:

'If we take 47, reverse and add, 47 + 74 = 121, which is palindromic.
'
'Not all numbers produce palindromes so quickly. For example,
'
'349 + 943 = 1292,
'1292 + 2921 = 4213
'4213 + 3124 = 7337
'
'That is, 349 took three iterations to arrive at a palindrome.
'
'Although no one has proved it yet, it is thought that some numbers, like
'196, never produce a palindrome. A number that never forms a palindrome
'through the reverse and add process is called a Lychrel number. Due to the
'theoretical nature of these numbers, and for the purpose of this problem,
'we shall assume that a number is Lychrel until proven otherwise. In addition
'you are given that for every number below ten-thousand, it will either
'(i) become a palindrome in less than fifty iterations, or, (ii) no one, with
'all the computing power that exists, has managed so far to map it to a
'palindrome. In fact, 10677 is the first number to be shown to require over
'fifty iterations before producing a palindrome:
'4668731596684224866951378664 (53 iterations, 28-digits).
'
'Surprisingly, there are palindromic numbers that are themselves Lychrel
'numbers; the first example is 4994.
'
'How many Lychrel numbers are there below ten-thousand?
'
'NOTE: Wording was modified slightly on 24 April 2007 to emphasise
'the theoretical nature of Lychrel numbers.

Euler problems should calculate under a minute. This one takes about 1.3 seconds.
Here is my code:

Option Explicit
Option Base 1
Sub Problem_055()

Dim i As Long
Dim j As Long
Dim T As Single
Dim n As String
Dim n_rev As String
Dim num As String
Dim Answer As Long
Dim Max As Long
Dim Last As Long
Dim IsTest As Boolean
Dim Series(5) As String

T = Timer 'start timing
IsTest = True
If IsTest Then 'to test the example cases
Max = 5
Last = 53
Series(1) = "47"
Series(2) = "196" 'Lychrel
Series(3) = "349"
Series(4) = "4994" 'Lychrel
Series(5) = "10677"
Else
Max = 9999 ' less than 10,000
Last = 50
end if

For j = 1 To Max
If IsTest Then
n = Series(j)
Else
n = CStr(j)
End If
For i = 1 To last 'to test 10677
n_rev = StrReverse(n)
num = AddAsStrings(n, n_rev)
If num = StrReverse(num) Then 'not a Lychrel number
Exit For
End If
n = num
If i = last Then
Answer = Answer + 1
End If
Next i
Next j

Debug.Print Answer; " Time:"; Timer - T

End Sub

It uses the AddAsStrings() function from Problem 16. It exits the loop if the addition is equal to its reverse.

Of course, the real question, is why anybody cares about Lychrel numbers, and who would make them their life's work

...mrt

Euler Problem 31

Michael — Sun, 28 Dec 2008 23:49:24 +0000

Euler Problem 31 states:

'In England the currency is made up of pound, £, and pence, p, and there are
'eight coins in general circulation:
'
' 1p, 2p, 5p, 10p, 20p, 50p, £1 (100p) and £2 (200p).
'
'It is possible to make £2 in the following way:
'
' 1×£1 + 1×50p + 2×20p + 1×5p + 1×2p + 3×1p
'
'How many different ways can £2 be made using any number of coins?

Over in the Euler Problem 16 thread, dbb provided his answer. This is dbb's code, copied from there, with 8 loops for eight coins:

Sub P31()

Dim P1 As Long, P2 As Long, P5 As Long, P10 As Long, P20 As Long
Dim P50 As Long, P100 As Long, P200 As Long
Dim n1 As Long, n2 As Long, n5 As Long, n10 As Long, n20 As Long
Dim n50 As Long, n100 As Long, n200 As Long
Dim n As Long

For P1 = 0 To 200 Step 1
n1 = P1
For P2 = 0 To 200 - n1 Step 2
n2 = n1 + P2
For P5 = 0 To 200 - n2 Step 5
n5 = n2 + P5
For P10 = 0 To 200 - n5 Step 10
n10 = n5 + P10
For P20 = 0 To 200 - n10 Step 20
n20 = n10 + P20
For P50 = 0 To 200 - n20 Step 50
n50 = n20 + P50
For P100 = 0 To 200 - n50 Step 100
n100 = n50 + P100
For P200 = 0 To 200 - n100 Step 200
If n100 + P200 = 200 Then
n = n + 1
End If
Next P200
Next P100
Next P50
Next P20
Next P10
Next P5
Next P2
Next P1
Debug.Print n

End Sub

It runs in a second and a half on my machine. Problem 76 looks very similar.

'It is possible to write five as a sum in exactly six different ways:
'
'4 + 1
'3 + 2
'3 + 1 + 1
'2 + 2 + 1
'2 + 1 + 1 + 1
'1 + 1 + 1 + 1 + 1
'
'How many different ways can one hundred be written as a sum of at least
'two positive integers?

Does that mean 100 loops are required?

...mrt

UDFs and Moving Add-in Files

Dick Kusleika — Tue, 23 Dec 2008 20:51:01 +0000

I don't use user defined functions in add-ins all that often, but I happen to have a particular add-in with one UDF. And I happened to have recently moved that add-in. And all my links happen to be broken.

Fortunately, Jan Karel has an exhaustive write-up on how to fix and prevent this problem. Go to FixLinks2UDF.

John Walkenbach, in Power Utility Pak, copies the UDF to the workbook in which it lives. I think that's perfect for a general purpose utility, but it goes against my rule of keeping code and layout separate. If I change the UDF, it won't be changed everywhere. I could make the argument that it shouldn't change for previously created reports, but I just don't know.

In this add-in, I already capture the opening of reports, so I suppose I'll just update the links as they're opened. In any event, I hope this link love kicks JKP's article higher on Google so I don't have to search so hard for it next time.

Euler Problem 16

Michael — Mon, 22 Dec 2008 13:47:42 +0000

Hello All -

While Dick and company do the heavy lifting around here writing about VBA Frameworks, I asked if I could contribute about lighter fare, specifically the Project Euler Challenges. I am a systems engineer by trade, and use Excel as a tool to manage requirements. I confessed to Dick I have probably never used an accounting-specific Excel function, though I've been using Excel since v1.5 (yep...that old).

Project Euler indicates that all the challenges can be computed in less than one minute of computer time. Once you find a right answer, it's like a password to review the thoughts, code, and comments of others who solved the problem before you. It's disconcerting to read from a 14-year-old coder who solved the problem in just a few lines of Haskell (what's that?). Nobody seems to be doing the problems in VBA, so I asked Dick if I could start conversations about how one might. One thing I won't post is the answers--that's a password you'll at least have to have Excel to get. And there are more than a few that I've attempted that I'm stuck on, and then there are the ones that I don't know how to start coding, and still others that I don't understand the mathematics. Never-the-less...

Did you know that Excel can compute 2^1000 in four tenths of a second?
I didn't either until I attempted Project Euler Problem 16 which states:

2^15 = 32768 and the sum of its digits is 3 + 2 + 7 + 6 + 8 = 26.

What is the sum of the digits of the number 2^1000?

There are two general tasks:

Time the calculation
Reproduce the example

and two specific tasks:

Compute 2 to the 1000
Calculate the sum of the digits

Here is my code:

Option Explicit
Option Base 1
Sub Problem_016()
Dim exp As Long
Dim i As Long
Dim j As Long
Dim Answer As Long
Dim M1 As String
Dim M2 As String
Dim T As Single
Dim IsTest As Boolean

T = Timer 'starts timing
IsTest = False
If IsTest Then 'to reproduce the test case
exp = 15
Else
exp = 1000
End If

M1 = "2"
For i = 2 To exp 'calculates 2^exp
M2 = AddAsStrings(M1, M1)
M1 = M2
Next i

For i = 1 To Len(M2) 'loops the length of 2^exp to sum digits
Answer = Answer + CLng(Mid(M2, i, 1))
Next i

Debug.Print Answer; " Time:"; Timer - T; M2

End Sub

And by the way, 2^1000 is precisely:
10715086071862673209484250490600018105614048117055336074437503883703510
51124936122493198378815695858127594672917553146825187145285692314043598
45775746985748039345677748242309854210746050623711418779541821530464749
83581941267398767559165543946077062914571196477686542167660429831652624
386837205668069376

The key part is the AddAsStrings() function. It does addition the way you learned it--starting from the right and carrying to columns on the left.

Function AddAsStrings(Adder1 As String, Adder2 As String) As String

Dim Sum As Long
Dim Carry As Long
Dim C As Long
Dim Answer As String

If Len(Adder1)> Len(Adder2) Then
For C = 1 To Len(Adder1) - Len(Adder2)
Adder2 = "0" & Adder2
Next C
ElseIf Len(Adder2)> Len(Adder1) Then
For C = 1 To Len(Adder2) - Len(Adder1)
Adder1 = "0" & Adder1
Next C
End If

For C = Len(Adder1) To 1 Step -1
Sum = Carry + CLng(Mid(Adder1, C, 1))
Sum = Sum + CLng(Mid(Adder2, C, 1))
Carry = Int(Sum / 10)
If C <> 1 Then
Answer = CStr(Sum Mod 10) & Answer
Else
Answer = CStr(Sum) & Answer
End If
Next C

AddAsStrings = Answer

End Function

AddAsStrings() does well on Fibonacci numbers, simple multiplication (including squaring), and factorials. It doesn't do as well on cubes and higher powers. It becomes loops inside loops. It works on powers of 2 because all we do is double and redouble...

You've seen me around here as both Michael and ...mrt. For whatever it helps, I'm pleased to contribute.

New Contributor

Dick Kusleika — Sun, 21 Dec 2008 20:30:30 +0000

Long time reader Michael Tollefson has been messing around with Project Euler. He has graciously offered to post some of his exploits here. Expect some posts from Michael soon.

VBA Framework II

Dick Kusleika — Sun, 21 Dec 2008 20:27:09 +0000

See VBA Framework for the first revision.

For this revision, you can select which VBProject in which to add the code and you can identify a parent class.

I refactored the code to use a class module to make the code more readable. Concatenating strings is always messy, so I hope this helps a little. I made a property for every variation of the class name I'd need. Here are some examples using the Paycheck class:

CSingular	CPaycheck
clsSingular	clsPaycheck
mcolPlural	mcolPaychecks
ParentName	Employee
CParentName	CEmployee
tblPlural	tblPaychecks

I couldn't identify the name of an unsaved workbook given the VBProject, so I used this code to fill the project combobox:

For Each vbProj In Application.VBE.VBProjects
sWbName = ""
lProjCnt = lProjCnt + 1
If vbProj.Protection = vbext_pp_none Then
Me.cbxProject.AddItem vbProj.Name
On Error Resume Next
sWbName = Dir(vbProj.Filename)
On Error GoTo 0

If Len(sWbName) = 0 Then
Me.cbxProject.List(Me.cbxProject.ListCount - 1, 1) = "(Unsaved Workbook)"
Else
Me.cbxProject.List(Me.cbxProject.ListCount - 1, 1) = sWbName
End If

Me.cbxProject.List(Me.cbxProject.ListCount - 1, 2) = lProjCnt
End If

Next vbProj

I just identify "Unsaved Workbook" if there is not a Filename property. I only list projects that aren't protected to avoid errors writing to protected projects. If there are existing classes in the project, I fill the Parent combobox thusly:

Private Sub cbxProject_AfterUpdate()

Dim vbc As VBComponent

Me.cbxParent.Clear
Me.cbxParent.AddItem gsNOPARENT
Me.cbxParent.ListIndex = 0

If Me.cbxProject.ListIndex> -1 Then
If mclsClass Is Nothing Then Set mclsClass = New CClass

Set mclsClass.Project = Application.VBE.VBProjects(Val(Me.cbxProject.List(Me.cbxProject.ListIndex, 2)))

For Each vbc In mclsClass.Project.VBComponents
If vbc.Type = vbext_ct_ClassModule Then
Me.cbxParent.AddItem vbc.Name
End If
Next vbc
End If

End Sub

I'd like to only include the singular versions of the classes, but I haven't gotten there yet. I imagine there are a lot of ways to relate classes, but I only code for one. Using the example mdb, there are a number of Employees stored in a global Collection variable. Each Employee instance has a Paychecks property which retrieves a CPaychecks collecton class. This holds CPaycheck objects that only relate to the Employee.

Download VBAFramework2.zip

Still on the to do list:

Browse to mdb instead of hardcoded
Create a userform to add/edit/delete records
Automatically set an ADO reference
Option to make functions instead of subs (for error handling)
Allow recreation of the classes and fill code
Option to make properties read-only
Your suggestions

Bowl Picking

Dick Kusleika — Fri, 19 Dec 2008 19:40:05 +0000

It's college football bowl season once again. I have a spreadsheet I use to help me identify winners and losers (for entertainment purposes only).

The four yardage columns are yards per game for rushing offense, rushing defense, passing offense, and passing defense, respectively. I'm trying to identify teams that have better defenses (because defense wins championships). While Wisconsin is rushing for 212 yards per game this season, Florida State is only allowing their opponents to rush for 127 yards per game. This, to me, is an advantage for Florida State.

California is +14 in turnovers, taking possession from their opponents more often than they give it away. That's turnover margin for the season, not per game. Miami, on the other hand, can't seem to hang on to the ball. It seems that Cal should get at least one turnover in their bowl game.

The Bowl Wins ratio is bowl games won to bowl games played. Western Michigan (not shown) has won zero bowl games in four attempts. Are they due for a win? Probably not. It's more likely that their coach doesn't prepare them well for bowl games.

Columns R & S are thresholds. If the disparity between rushing offense and defense is more than 75 yards per game, I think that's significant and I want to know about it. If a team has won more than 65% of their games or less than 35%, I want to know. But I can change those values if I like.

The hidden columns J:O are used in the conditional formatting of the other columns. They are:

J: =MOD(ROW(),2)=1 'Tells me if I'm comparing the team above or below
K: =IF(J2,D2-E1,D2-E3) 'Rushing offense differential
L: =IF(J2,E2-D1,E2-D3) 'Rushing defense differential
M: =IF(J2,F2-G1,F2-G3) 'Passing offense differential
N: =IF(J2,G2-F1,G2-F3) 'Passing defense differential
O: =IF(MOD(ROW(),2)=1,H2-H1,H2-H3) 'turnover differential
P: =VLOOKUP(B2,Bowls!$A$1:$F$119,2,FALSE)/VLOOKUP(B2,Bowls!$A$1:$F$119,5,FALSE) 'bowl winning percentage

These formulas drive the conditional formatting in D:I. The conditional formats all look something like this:

You can download BowlStats2008.xls.zip

So if you want to go .500 like me, now you have the tools.

Create Unique List from Selected Cells

Dick Kusleika — Thu, 11 Dec 2008 23:13:36 +0000

Well, it's almost next year and you know what that means: New vendor files. I need to create a couple hundred labels for next year's vendor files. I started by exporting all of the bills from all of the vendors for this year. Next, I'm going to count and sum the bills. Then I'm going to find the newest invoice date. With that, I should be able to weed out vendors we likely won't pay next year and those whose invoices are so few that they go in the Misc. folder.

But I need to start with a list of all the vendors who had bills. I'm so sick of creating unique lists with formulas, that I finally just wrote a utility to do it.

Recently added to my Personal.xls

Sub GetUniqueList()

Dim rCell As Range
Dim colUnique As Collection
Dim sh As Worksheet
Dim i As Long

'only work on ranges
If TypeName(Selection) = "Range" Then

'create a new collection
Set colUnique = New Collection

'loop through all selected cells
'and add to collection
For Each rCell In Selection.Cells
On Error Resume Next
'if value exists, it won't be added
colUnique.Add rCell.Value, CStr(rCell.Value)
On Error GoTo 0
Next rCell

'make a new sheet to put the unique list
Set sh = ActiveWorkbook.Worksheets.Add

'Write the unique list to the new sheet
For i = 1 To colUnique.Count
sh.Range("A1").Offset(i, 0).Value = colUnique(i)
Next i

'sort with no headers
sh.Range(sh.Range("A2"), sh.Range("A2").End(xlDown)) _
.Sort sh.Range("A2"), xlAscending, , , , , , xlNo

End If

End Sub

VBA Framework

Dick Kusleika — Mon, 08 Dec 2008 01:49:00 +0000

In Create Classes... I had this todo list:

~~Create the class module rather than copy and paste~~
~~Name the class module based on the table name~~
~~Select the database and table from a list on a userform~~
~~Establish Parent Child relationships between two classes~~
~~Create functions to fill the class from a recordset~~
Create a userform to add/edit/delete records

I need to add

Create relationships between two child classes
Automatically set an ADO reference
Option to make functions instead of subs (for error handling)
Allow recreation of the classes and fill code

You can Download Payroll.zip. It contains the VBAFramework.xls workbook and a Payroll.mdb Access database.

Here's where it all starts

Public Sub PickTable()

Dim axCat As ADOX.Catalog
Dim ufSelect As USelectTable
Dim vaSelected As Variant
Dim axTable As ADOX.Table
Dim i As Long
Dim sChildCode As String, sParentCode As String
Dim sFillCode As String

InitializeConnection

Set axCat = New ADOX.Catalog
Set axCat.ActiveConnection = gadCon

Set ufSelect = New USelectTable
Set ufSelect.Catalog = axCat
ufSelect.Initialize
ufSelect.Show

If Not ufSelect.UserCancel Then
vaSelected = ufSelect.SelectedFields
Set axTable = ufSelect.Table

If ActiveWorkbook.Name = ThisWorkbook.Name Then Workbooks.Add

ChildClassCode axTable, vaSelected, sChildCode
MakeChildClass axTable, sChildCode

ParentClassCode axTable, sParentCode
MakeParentClass axTable, sParentCode

FillClassesCode axTable, vaSelected, sFillCode
MakeFillModule axTable, sFillCode

End If

Set axCat = Nothing
Unload ufSelect
Set ufSelect = Nothing

End Sub

Most of the code is bunch of string concatenation, which is pretty boring. But not as boring as actually typing the code. When you run PickTable, you get

It allows you to select a table and fields to include in your classes. The code creates a class based on the field and a collection class to serve as its parent. Then it creates (or modifies an existing) standard module that holds code to fill the classes.

There's no customization options (it's in pre-Beta). But if you happen to use the same conventions as me, it will work perfectly. First, it assumes you name your Access tables as plural and your classes exactly the same way (but singular for the child class). It assumes you have an ID field that is SingularTableNameID, so tblEmployees will have an EmployeeID field. That one is used to uniquely identify the record in the collection class, so it's important. I should probably not allow the user to deselect that one in the listbox. Oh yeah, it also assumes you prefix your tables with "tbl". Everyone does that, right?

I imagine I'll add some customization options as I go so it's useful to more than just me. So if there's a convention that's near and dear to your heart, leave a comment. But I don't plan on making it fully customizable. I'm going the Ruby on Rails route of "this will work as long as you do it just like me".

Let me know what you think.