davidboutche
02-05-2010, 10:42 AM
I've been adapting a piece of code that P45cal kindly provided for some time now getting it to count a tally of repetition of word in a column.
What I've been trying to get it to do now is count postcode. I made function for it to recognise postcodes like this PO143HU. However, postcode aren't always written in the data in this format. They are sometimes mixed like PO14 3HU.
I've been trying to get the code to look for the first parts, join them together with the second parts and call that new word.... unless the original word looked like a post code.
I've had it working with just the partones and parttwos but am having trouble getting it to include the whole posts code.
The code is as below:
Sub joiningcodecruncher()
'make sure the right sheet is the active sheet
Dim Ignore As Range
Set tally = CreateObject("Scripting.Dictionary")
For Each cll In Intersect(ActiveSheet.UsedRange, Columns(1))
x = Split(cll.Value, " ")
For Each word In x
If Lookslikepartone(word) Then string1 = word
If Lookslikeparttwo(word) Then string2 = word
If Lookslikepostcode(word) Then postcode = word Else postcode = string1 & string2
Next word
If Lookslikepostcode(postcode) Then
If tally.exists(postcode) Then
tally(postcode) = tally(postcode) + 1
Else
tally.Add postcode, 1
End If
End If
Next cll
myCount = tally.Count
Set NewWs = ActiveWorkbook.Sheets.Add(after:=Worksheets(Worksheets.Count))
NewWs.Range("A1").Resize(myCount) = Application.Transpose(tally.keys)
NewWs.Range("B1").Resize(myCount) = Application.Transpose(tally.Items)
NewWs.UsedRange.Sort Key1:=Range("B1"), Order1:=xlDescending, Header:=xlNo, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal
NewWs.Rows(1).Insert
Range("A1:B1") = Array("Number", "Count")
msg = "Results:" & vbLf
For i = 2 To Application.Min(myCount, 10) + 1 ' the 10 here is for the top 10
zz = NewWs.Cells(i, 2)
msg = msg & vbLf & NewWs.Cells(i, 1) & " occurs " & IIf(NewWs.Cells(i, 2) < 3, Choose(NewWs.Cells(i, 2), "once", "twice"), NewWs.Cells(i, 2) & " times")
Next i
MsgBox "Let's look at links, here's your top ten!" & vbLf & msg
End Sub
Function Lookslikepostcode(TheString) As Boolean
If Len(TheString) > 5 And Len(TheString) < 8 Then '5 to 7 digits for uk postcodes (for those without a space that is) see http://en.wikipedia.org/wiki/Postcodes_in_the_United_Kingdom#Format
AscLetter1 = Asc(Left(TheString, 1)) 'should be a letter
AscLetter2 = Asc(Mid(TheString, 2, 1)) 'should be a letter
AscLetter3 = Asc(Mid(TheString, 3, 1)) 'should be a numeral
AscLetter7 = Asc(Right(TheString, 1)) 'shoud be a letter
Length = Len(TheString) 'is the string length
AscLetter6pos = Length - 1 'is the position of the last letter minus 1
AscLetter6 = Asc(Mid(TheString, AscLetter6pos, 1)) 'should be a letter
AscLetter5pos = Length - 2 ' is the position of the last letter minus 2
AscLetter5 = Asc(Mid(TheString, AscLetter5pos, 1)) 'should be a number
If ((AscLetter1 > 64 And AscLetter1 < 91) Or (AscLetter1 > 96 And AscLetter1 < 123)) And _
((AscLetter2 > 64 And AscLetter2 < 91) Or (AscLetter2 > 96 And AscLetter2 < 123)) And _
((AscLetter7 > 64 And AscLetter7 < 91) Or (AscLetter7 > 96 And AscLetter7 < 123)) And _
((AscLetter6 > 64 And AscLetter6 < 91) Or (AscLetter6 > 96 And AscLetter6 < 123)) And _
(AscLetter3 > 47 And AscLetter3 < 58) And _
(AscLetter5 > 47 And AscLetter5 < 58) Then Lookslikepostcode = True
End If
End Function
Function Lookslikepartone(TheString) As Boolean
If Len(TheString) > 2 And Len(TheString) < 5 Then 'finds the first part of postcodes that have been split
AscLetter1 = Asc(Left(TheString, 1)) 'should be a letter
AscLetter2 = Asc(Mid(TheString, 2, 1)) 'should be a letter
AscLetter3 = Asc(Mid(TheString, 3, 1)) 'should be a numeral
If ((AscLetter1 > 64 And AscLetter1 < 91) Or (AscLetter1 > 96 And AscLetter1 < 123)) And _
((AscLetter2 > 64 And AscLetter2 < 91) Or (AscLetter2 > 96 And AscLetter2 < 123)) And _
(AscLetter3 > 47 And AscLetter3 < 58) Then Lookslikepartone = True
End If
End Function
Function Lookslikeparttwo(TheString) As Boolean
If Len(TheString) > 2 And Len(TheString) < 5 Then 'finds the first part of postcodes that have been split
AscLetter1 = Asc(Left(TheString, 1)) 'should be a numeral
AscLetter2 = Asc(Mid(TheString, 2, 1)) 'should be a letter
AscLetter3 = Asc(Mid(TheString, 3, 1)) 'should be a letter
If (AscLetter1 > 47 And AscLetter1 < 58) And _
((AscLetter2 > 64 And AscLetter2 < 91) Or (AscLetter2 > 96 And AscLetter2 < 123)) And _
((AscLetter3 > 64 And AscLetter3 < 91) Or (AscLetter2 > 96 And AscLetter2 < 123)) Then Lookslikeparttwo = True
End If
End Function
It seems to be producing some odd result which I'm sure to someone more experience will be obvious but I just can't quite get it right.
Attached is a zip of the whole file.
Thanks
David
What I've been trying to get it to do now is count postcode. I made function for it to recognise postcodes like this PO143HU. However, postcode aren't always written in the data in this format. They are sometimes mixed like PO14 3HU.
I've been trying to get the code to look for the first parts, join them together with the second parts and call that new word.... unless the original word looked like a post code.
I've had it working with just the partones and parttwos but am having trouble getting it to include the whole posts code.
The code is as below:
Sub joiningcodecruncher()
'make sure the right sheet is the active sheet
Dim Ignore As Range
Set tally = CreateObject("Scripting.Dictionary")
For Each cll In Intersect(ActiveSheet.UsedRange, Columns(1))
x = Split(cll.Value, " ")
For Each word In x
If Lookslikepartone(word) Then string1 = word
If Lookslikeparttwo(word) Then string2 = word
If Lookslikepostcode(word) Then postcode = word Else postcode = string1 & string2
Next word
If Lookslikepostcode(postcode) Then
If tally.exists(postcode) Then
tally(postcode) = tally(postcode) + 1
Else
tally.Add postcode, 1
End If
End If
Next cll
myCount = tally.Count
Set NewWs = ActiveWorkbook.Sheets.Add(after:=Worksheets(Worksheets.Count))
NewWs.Range("A1").Resize(myCount) = Application.Transpose(tally.keys)
NewWs.Range("B1").Resize(myCount) = Application.Transpose(tally.Items)
NewWs.UsedRange.Sort Key1:=Range("B1"), Order1:=xlDescending, Header:=xlNo, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal
NewWs.Rows(1).Insert
Range("A1:B1") = Array("Number", "Count")
msg = "Results:" & vbLf
For i = 2 To Application.Min(myCount, 10) + 1 ' the 10 here is for the top 10
zz = NewWs.Cells(i, 2)
msg = msg & vbLf & NewWs.Cells(i, 1) & " occurs " & IIf(NewWs.Cells(i, 2) < 3, Choose(NewWs.Cells(i, 2), "once", "twice"), NewWs.Cells(i, 2) & " times")
Next i
MsgBox "Let's look at links, here's your top ten!" & vbLf & msg
End Sub
Function Lookslikepostcode(TheString) As Boolean
If Len(TheString) > 5 And Len(TheString) < 8 Then '5 to 7 digits for uk postcodes (for those without a space that is) see http://en.wikipedia.org/wiki/Postcodes_in_the_United_Kingdom#Format
AscLetter1 = Asc(Left(TheString, 1)) 'should be a letter
AscLetter2 = Asc(Mid(TheString, 2, 1)) 'should be a letter
AscLetter3 = Asc(Mid(TheString, 3, 1)) 'should be a numeral
AscLetter7 = Asc(Right(TheString, 1)) 'shoud be a letter
Length = Len(TheString) 'is the string length
AscLetter6pos = Length - 1 'is the position of the last letter minus 1
AscLetter6 = Asc(Mid(TheString, AscLetter6pos, 1)) 'should be a letter
AscLetter5pos = Length - 2 ' is the position of the last letter minus 2
AscLetter5 = Asc(Mid(TheString, AscLetter5pos, 1)) 'should be a number
If ((AscLetter1 > 64 And AscLetter1 < 91) Or (AscLetter1 > 96 And AscLetter1 < 123)) And _
((AscLetter2 > 64 And AscLetter2 < 91) Or (AscLetter2 > 96 And AscLetter2 < 123)) And _
((AscLetter7 > 64 And AscLetter7 < 91) Or (AscLetter7 > 96 And AscLetter7 < 123)) And _
((AscLetter6 > 64 And AscLetter6 < 91) Or (AscLetter6 > 96 And AscLetter6 < 123)) And _
(AscLetter3 > 47 And AscLetter3 < 58) And _
(AscLetter5 > 47 And AscLetter5 < 58) Then Lookslikepostcode = True
End If
End Function
Function Lookslikepartone(TheString) As Boolean
If Len(TheString) > 2 And Len(TheString) < 5 Then 'finds the first part of postcodes that have been split
AscLetter1 = Asc(Left(TheString, 1)) 'should be a letter
AscLetter2 = Asc(Mid(TheString, 2, 1)) 'should be a letter
AscLetter3 = Asc(Mid(TheString, 3, 1)) 'should be a numeral
If ((AscLetter1 > 64 And AscLetter1 < 91) Or (AscLetter1 > 96 And AscLetter1 < 123)) And _
((AscLetter2 > 64 And AscLetter2 < 91) Or (AscLetter2 > 96 And AscLetter2 < 123)) And _
(AscLetter3 > 47 And AscLetter3 < 58) Then Lookslikepartone = True
End If
End Function
Function Lookslikeparttwo(TheString) As Boolean
If Len(TheString) > 2 And Len(TheString) < 5 Then 'finds the first part of postcodes that have been split
AscLetter1 = Asc(Left(TheString, 1)) 'should be a numeral
AscLetter2 = Asc(Mid(TheString, 2, 1)) 'should be a letter
AscLetter3 = Asc(Mid(TheString, 3, 1)) 'should be a letter
If (AscLetter1 > 47 And AscLetter1 < 58) And _
((AscLetter2 > 64 And AscLetter2 < 91) Or (AscLetter2 > 96 And AscLetter2 < 123)) And _
((AscLetter3 > 64 And AscLetter3 < 91) Or (AscLetter2 > 96 And AscLetter2 < 123)) Then Lookslikeparttwo = True
End If
End Function
It seems to be producing some odd result which I'm sure to someone more experience will be obvious but I just can't quite get it right.
Attached is a zip of the whole file.
Thanks
David