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?
‘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:DownloadsEuler
ames.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
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:DownloadsEuler
ames.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
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
For a code-less solution see http://www.tushar-mehta.com/misc_tutorials/project_euler/euler022.html
This is also one of the few Euler problems you can do entirely in a worksheet
This runs in less than a second
Dim c0 As String, c1 As Long, c2 As Long, t As Single
t = Timer
c0 = “ACDEFGHIJKLMNOPQRSTUVWXYZ”
Workbooks.Open “E:download
ames.txt”
With ActiveWorkbook.Sheets(1)
sq = Split(Replace(Join(Split(.Range(“A1”), “”“,”“”), “|”), “,” & Chr(34), “|”), “|”)
.Range(“A1”).Resize(UBound(sq)) = Application.WorksheetFunction.Transpose(sq)
With .Columns(1)
.Sort [A1]
sq = .SpecialCells(xlCellTypeConstants)
End With
End With
For j = 1 To UBound(sq)
c1 = 0
For jj = 1 To Len(sq(j, 1))
c1 = c1 + InStr(c0, Mid(sq(j, 1), jj, 1))
Next
c2 = c2 + c1 * j
Next
t = Timer – t
Debug.Print “total “ & c2 & ” time “ & t
End Sub
Some improvements:
Dim c1 As Single, c2 As Long, T As Long, j As Integer, jj As Integer, Rng As Range
Const c0 = “ACDEFGHIJKLMNOPQRSTUVWXYZ”
T = Timer
Open “E:download
ames.txt” For Input As #1
sq = Split(Mid(Input(LOF(1) – 1, #1), 2), “”“,”“”)
Close #1
Workbooks.Add
Set Rng = ActiveWorkbook.Sheets(1).Cells(1, 1).Resize(UBound(sq) + 1)
Rng = Application.WorksheetFunction.Transpose(sq)
Rng.Sort [A1]
sq = Rng
For j = 1 To UBound(sq)
c1 = 0
For jj = 1 To Len(sq(j, 1))
c1 = c1 + InStr(c0, Mid(sq(j, 1), jj, 1))
Next
c2 = c2 + (c1 * j)
Next
Debug.Print “total: “ & c2 & ” time: “ & Timer – T
End Sub