Join and Count

[davidboutche]

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:
[VBA]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/Postcod...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[/VBA]

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

[Bob Phillips]

Just strip out the space

[vba]

cll.Value = Replace(cll.Value, " ", "")
[/vba]

[davidboutche]

Not quite there yet I'm afraid. Where were you suggesting I put the replace line?

The problem seems to be, it's adding an exra count occasionally and on the last row that it uses, I get a count of
59628


So I'm still not quite sure where this is going wrong?

[Bob Phillips]

I wasn't, I was giving you the technique. Rather than split the cell value, I was saying ignore the spaces then the orginal code should work.

Post a workbook if you are stuck.

[davidboutche]

I am a little struck i'm afraid. Each cell contains both postcodes and other data. I was using the split function to break the cell data up and then the three lookslike functions to decide if the word was the start, end or entire postcode.

It's almost there, it's just producing a couple of odd results, like the last row ending with a count of 59000.

There should be a work book attached as a zip further up. Please remember each cell will contain more data than just postcodes.

[Bob Phillips]

Two things. First I have no idea what those menu options do or what I need to do to run a test, and second if i try anything it all crashes on me.

[davidboutche]

Sorry, the macros aren't built into that menu yet. If you just go, 'tools', macros, and select joiningcodecruncher that should run the macro that I've been working on.

[mdmackillop]

This uses RegExp and LIKE for two solutions.

Please only post samples and code relevant to the question. It makes things simpler.