Solved: Extracting 5 or 6 digit numbers from a cell

[davidboutche]

The problem:
I have one column of data containing words and variable lengths of sets of numbers.

What I want:
I want to extract all the five or six digit numbers from that cell and place them individually into the proceeding columns

Then I want to count the total number of times each of those numbers appear.
Ultimately creating a top ten list of numbers featuring in the text.

There are other numbers in the text, but they relate to times and dates so all I want is the 5 and 6 digit numbers.

I think I should be using the instring() and len() functions to do this but I'm really not sure how to use them that well.

I've attached a sample book if anyone can help please.

David

[Bob Phillips]

That looks a bit tricky, what are the rules? The second line has two 6 digit numbers.

[mdmackillop]

Before we start analysing, test this to extract your numbers.
[VBA]
Option Explicit
Sub LongNos()
Dim i As Long, txt, y As String, cel As Range, x As Long


For Each cel In Selection
i = 1
txt = Split(cel)
For x = 0 To UBound(txt)
y = txt(x)
If IsNumeric(y) And (Len(y) = 5 Or Len(y) = 6) Then
cel.Offset(, i) = y
i = i + 1
End If
Next
Next
End Sub

[/VBA]

[davidboutche]

yes that worked super. Although I had to highlight all cells i think to make it work on all cells i think. But I believe this can be got around using the an offset?

Next task is to count the repetitions?

[mbarron]

Try this:

[VBA]Sub Get5or6()
Dim oCol As Long, i As Integer, rData As Range, aData() As String
Dim j As Long, k As Long
oCol = 1

For Each rData In Selection
aData = Split(rData, " ")
For i = 0 To UBound(aData)
If IsNumeric(aData(i)) And (Len(aData(i)) = 5 Or Len(aData(i)) = 6) Then
Cells(oCol, 2) = aData(i)
oCol = oCol + 1
End If
Next
Next


For j = 1 To oCol - 1
Cells(j, 3) = Application.WorksheetFunction.CountIf(Range(Cells(1, 2), Cells(oCol - 1, 2)), Cells(j, 2))
Next

Range(Cells(1, 2), Cells(oCol - 1, 3)).Sort Key1:=Range("C1"), Order1:=xlDescending, Key2:=Range("B1"), _
Order2:=xlAscending, Header:=xlGuess, OrderCustom:=1, MatchCase:=False, _
Orientation:=xlTopToBottom, DataOption1:=xlSortNormal, DataOption2:=xlSortNormal

For k = oCol - 1 To 2 Step -1
If Cells(k - 1, 2) = Cells(k, 2) Then
Range(Cells(k, 2), Cells(k, 3)).Delete shift:=xlUp
End If
Next


End Sub
[/vba]

[p45cal]

Seems we all had a go at this one. See attached and here's the code:
[vba]Sub blah()
'make sure the right sheet is the active sheet
Set Tally = CreateObject("Scripting.Dictionary")
For Each cll In Intersect(ActiveSheet.UsedRange, Columns(1))
x = Split(cll.Value, " ")
For Each word In x
If (Len(word) = 5 Or Len(word) = 6) And IsNumeric(word) Then
If Tally.exists(word) Then
Tally(word) = Tally(word) + 1
Else
Tally.Add word, 1
End If
End If
Next word
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
'the rest is optional:
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
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 msg
End Sub[/vba]It adds a new sheet with the results, there's a button to click in the attached.
It does rely on the data being delimited by spaces.

I take it that you don't really need the bit in bold here:"all the five or six digit numbers from that cell and place them individually into the proceeding columns"

[davidboutche]

barron when i try your sub with my sheet, i get the error

Named Argument Not Found

When I debug it, it is highlighting
[VBA]DataOption1:=[/VBA]]

Any ideas there? I'm using excel 2000 if that makes any difference.

The other sub written by p45cal vbmenu_register("postmenu_197606", true); - I tried it on the attached workbook and although it does seem to work it returns the error

application - defined or object - defined error

When debugged it highlights
[VBA]NewWs.UsedRange.Sort Key1:=Range("B1"), Order1:=xlDescending, Header:=xlNo, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal[/VBA]

Felt very close but didn't quite work. I did try the sub on my own sheet with the real data but it returned a different error. Just for info, my own sheet contains 63000 rows.

I take it that you don't really need the bit in bold here:"all the five or six digit numbers from that cell and place them individually into the proceeding columns"

Quite right, that was only to break down the process of what i was trying to achieve.

[p45cal]

I think if you were to delete everything (including the comma) after
xlTopToBottom
in that sorting multiline, it might work in xl2000.

It was changed in xl2002, and sorting's changed again in xl2007.

[davidboutche]

worked that time without the xltop.....
works with your data fine
works with most of my data fine
if I cut a load of cells from my sheet into yours it works well, if i put all the data in falls over, i think from memory the error was type mismatch. Is there some data in my sheet that isn't in the right format maybe? it could be difficult finding it through 63000 rows.

I'm not with that data till next week but I'm very curious in the mean time as to what the problem might be.

If anyone could explain to me what goes on in the above code that would be really helpful too. I don't just want to copy someone else's code without knowing how to use it myself next time.

[p45cal]

re:"worked that time without the xltop....."
actually, xltoptobottom should remain leaving:
[vba]NewWs.UsedRange.Sort Key1:=Range("B1"), Order1:=xlDescending, Header:=xlNo, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom[/vba]yes?

I've just remembered something.. in xl2000/2002, there was a real gotcha bug; if there's any conditional formatting on the sheet that's being processed, that can interfere with the split function, so remove all conditional formatting. You can find cells with conditional formatting by pressing F5 on the keyboard, clicking the Special.. button, choosing Conditional formats and All, click OK. Then if there are cells selected, go to the dropdown menus, choose Format|Conditional formatting..., click the Delete.. button, check all the 3 conditions, click OK.

Try again.

[davidboutche]

Sorry, yes, that was what I did.... i was writing in a hurry before leaving work.

[davidboutche]

Using the following code it seems to be doing it's job really well although it does seem to pick out the occassional 4 digit number, although that's not a big problem.

[vba]Sub blah()
'makes sure the right sheet is the active sheet
Set Tally = CreateObject("Scripting.Dictionary")
For Each cll In Intersect(ActiveSheet.UsedRange, Columns(1))
x = Split(cll.Value, " ")
For Each word In x
If (Len(word) = 5 Or Len(word) = 6) And IsNumeric(word) Then
If Tally.exists(word) Then
Tally(word) = Tally(word) + 1
Else
Tally.Add word, 1
End If
End If
Next word
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
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 msg
End Sub[/vba]
What it's getting stuck on is the size of the data processed. If I limit it to chunks of 3000 rows it seems fine, but when I give it anything over about 4 or 5000 cells it returns a 'Run Time error 13': Type Mismatch

The debugger highlights:
[vba]NewWs.Range("A1").Resize(myCount) = Application.Transpose(Tally.keys)[/vba]
If i hover over mycount it shows 31499 every time the procedure is called.
I am working with 34035 cells of data

Is this possibly memory allocation limit ?

[mdmackillop]

UsedRange could be excessive. Check for the last used row in column 1 and use that to define the range, rather than the Intersect method

[davidboutche]

I think I understand what you're saying. The last cell is in column A row 49221..

What part of the code should I try changing to include this?

[mdmackillop]

You might try this to eliminate 4 character items; also Dim Word as string, to avoid problems with leading 0s. These might be ignored in the code as written.

[VBA]
If (Len(trim(word)) = 5 Or Len(trim(word)) = 6) And IsNumeric(trim(word)) Then

[/VBA]

[mdmackillop]

I think I understand what you're saying. The last cell is in column A row 49221..

What part of the code should I try changing to include this?

[VBA]
For Each cll In Intersect(ActiveSheet.UsedRange, Columns(1))

[/VBA]

[davidboutche]

It's a bit of a stab in the dark, but are you stalking about something like this?

For Each cll In ActiveSheet.range(49221, Columns(1))

Sorry, i'm really quite new at this level of vba

[mdmackillop]

This is typically how it is done

[VBA]
For Each cll In Range(Cells(1, 1), Cells(Rows.Count, 1).End(xlUp))
[/VBA]

[davidboutche]

Im afraid that gave the same error. Runtime error 13 Type mismatch highlighting
[VBA]NewWs.Range("A1").Resize(mycount) = Application.Transpose(Tally.keys)[/VBA]

[p45cal]

You might try this to eliminate 4 character items; also Dim Word as string, to avoid problems with leading 0s. These might be ignored in the code as written.

[vba]
If (Len(trim(word)) = 5 Or Len(trim(word)) = 6) And IsNumeric(trim(word)) Then

[/vba]

I hope there aren't any instances of word having trailing/leading spaces.. the split function uses a space to split the data.If you have multiple spaces in the string being split, you get several "" in the resulting array - and these will fail the len test.