16 Digit number output

I'm running a sub that goes through the cells on a spreadsheet, extracts numbers 16 digits long (credit cards) and then put them into a tally counting how many times each number occurs. This works very well but I'm suffering the 16 digit problem. Inputting the numbers is fine, I format the cells as texts only but when it outputs them the other end it changes them to the exponential format. How can I force it to keep the text as text and not turn it into a number?


[VBA]Sub vehiclecruncherfree()
'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 ContainsLettersAndNumbers(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
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[/VBA]

The code is almost identical to the above except, it limits the words to 16 digits and contains numbers only.

I cannot see where you are outputting the 16 digit number, but you can try just preceding it with a ' (apostrophe).

Could you attach a sample wb? No real numbers of course, but 10-15 rows of 'good' fake data would help. Leastwise for me, guessing at what 'ContainsLettersAndNumbers' is doing seems less than productive...

Thanks,

Mark

I'm not too great with the code myself. It was originally supplied by pascal. It outputs the tally by opening a new worksheet and then displaying two columns, the first with the number and the second with the time occured.

I think it uses this part of the code to do this.
[VBA]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")[/VBA]

Where would I put the approstrophe?

Quote:

---

Originally Posted by GTO

Could you attach a sample wb? No real numbers of course, but 10-15 rows of 'good' fake data would help. Leastwise for me, guessing at what 'ContainsLettersAndNumbers' is doing seems less than productive...

Thanks,

Mark

---

I can, but not at the moment as I don't have the latest copy of the file. The real one doesn't contain the letters and numbers function. This is used for the same sort of function but looking at car number plates instead. The latest version has the code around that point:

[VBA]
if digits = 16 and isnumeric then
[/VBA]

Ok, so attached is a copy of the file I am using. Data is entered in the first column. I have applied the format control to make these text entries which keeps the 16 digits as they should be. A series of buttons pressed, Financial, LongCard Number, which run the macro below:
[VBA]Sub longcardcruncher()
digits = 16
'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(Trim(word)) = digits 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).NumberFormat = "@"
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[/VBA]

The result are written to a new sheet. The problem is the 16 digit numbers are returned to their exponential format and then chopping the end off so 1111111111111111 would become 1111111111111110. Someone mentioned using an " ' " but I'm not quite sure where to put it.

Any other ideas?

I think I've managed to solve it with the " ' ".
[VBA]Sub longcardcruncher()
digits = 16
'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(Trim(word)) = digits Then
word = word & "'"
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).NumberFormat = "@"
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[/VBA]

The code seems to work. If any one can see any flaws let me know.