Code To List Numbers Missing From Sequence

Dazzawm

Dazzawm

Well-known Member
Joined
Jan 24, 2011
Messages
3,786
Office Version
  1. 365
Platform
  1. Windows
I have a very long list of numbers in column A and I would like a code to tell me which numbers are missing from the sequence. Below is an example.

Excel 2010
A
SS9822
SS9824
SS9826
SS9828
SS9830
SS9831
SS9833

<colgroup><col style="width: 25pxpx" https:="" www.mrexcel.com="" forum="" usertag.php?do="list&action=hash&hash=DAE7F5"" target="_blank"></colgroup><colgroup><col></colgroup><thead>
</thead><tbody>
[TD="align: center"]4565[/TD]

[TD="align: center"]4566[/TD]

[TD="align: center"]4567[/TD]

[TD="align: center"]4568[/TD]

[TD="align: center"]4569[/TD]

[TD="align: center"]4570[/TD]

[TD="align: center"]4571[/TD]

</tbody>

​



So from above the following numbers are missing so I would like a list of these made in column D.

Excel 2010
D
SS9823
SS9825
SS9827
SS9829
SS9832

<colgroup><col style="width: 25pxpx" https:="" www.mrexcel.com="" forum="" usertag.php?do="list&action=hash&hash=DAE7F5"" target="_blank"></colgroup><colgroup><col></colgroup><thead>
</thead><tbody>
[TD="align: center"]4565[/TD]

[TD="align: center"]4566[/TD]

[TD="align: center"]4567[/TD]

[TD="align: center"]4568[/TD]

[TD="align: center"]4569[/TD]

</tbody>

​



Thanks
 
Last edited:
Sort by date Sort by votes
I really need the code to cater for letters on the end and more than 8 if possible. Thanks.
 
Upvote 0

Excel Facts

What is the fastest way to copy a formula?
If A2:A50000 contain data. Enter a formula in B2. Select B2. Double-click the Fill Handle and Excel will shoot the formula down to B50000.
The sample you sent me already had the parts after removing the letters on the end.
Therefore, this code ignores the ones that end with letters. Do you need the letters to be removed and the resulting part to remain there for processing?

uFoyw6z.png


<strike></strike>
Code: 
Sub Satv()                                          ' run me
Dim orig As Worksheet, aux As Worksheet, lr%, bsr As Range, i%
Set aux = Sheets("sheet1")                          ' auxiliary sheet
Set orig = Sheets("plan2")                          ' original sheet
orig.[d:d].ClearContents
orig.[d1] = "Result"
aux.Activate
Cells.ClearContents
orig.[a:a].Copy aux.[aa1]
[ab2].Formula = "=not(iserr(value(right(aa2,1))))"  ' no letter on the right side
Range("aa:aa").AdvancedFilter xlFilterCopy, [ab1:ab2], [a1], True
lr = Range("a" & Rows.Count).End(xlUp).Row
[b1] = "Len"
[b2].FormulaR1C1 = "=LEN(RC[-1])"
[b2].AutoFill Destination:=Range("B2:B" & lr), Type:=xlFillDefault
[c1] = [b1]
Range("b1:b" & lr).AdvancedFilter xlFilterCopy, [c1:c2], [d1], True
Set bsr = [e1]
For i = 2 To Range("d" & Rows.Count).End(xlUp).Row
    bsr.Offset(1).Formula = "=b2=" & Cells(i, 4)
    Range("a1:b" & lr).AdvancedFilter xlFilterCopy, bsr.Resize(2, 1), bsr.Offset(, 1), False
    DM bsr.Offset(1, 2), bsr.Offset(1, 1), bsr.Offset(1, 3)
    Range(Cells(2, bsr.Offset(, 3).Column), Cells(Range(Split(bsr.Offset(, 3).Address, "$")(1) _
    & Rows.Count).End(xlUp).Row, bsr.Offset(, 3).Column)).Copy _
    orig.Cells(orig.Range("d" & Rows.Count).End(xlUp).Row + 1, 4)
    Set bsr = bsr.Offset(, 4)
Next
End Sub

Sub DM(totrange As Range, dr As Range, dest As Range)
Dim a, lr, i&, d As Object, mn&, mx&, pref$, it, j%
Set d = CreateObject("Scripting.Dictionary")
lr = Range(Split(dr.Address, "$")(1) & Rows.Count).End(xlUp).Row
ReDim a(2 To lr)
j = 0
Do
    j = j + 1
Loop While Not IsNumeric(Mid(dr, j, 1)) And j < 20
j = j - 1
pref = Left(dr, j)
mx = 0
For i = 2 To lr
    a(i) = Right(Cells(i, dr.Column), Len(Cells(i, dr.Column)) - j)
    If i = 2 Then mn = a(i)
    If a(i) < mn Then mn = a(i)
    If a(i) > mx Then mx = a(i)
Next
For i = mn To mx
    it = pref & WorksheetFunction.Rept("0", totrange.Value - Len(pref & i)) & i
    d.Add it, it
Next
For i = 2 To lr
    If d.Exists(Cells(i, dr.Column).Value) Then d.Remove Cells(i, dr.Column).Value
Next
dest.Resize(d.Count).Value = WorksheetFunction.Transpose(d.Keys)
End Sub
 
Upvote 0
In a nutshell the prefix in a file will be the same and the amount of characters in each cell may vary. Also some may have letters on the end.
 
Upvote 0
Ricks code seems to work great but only up to 8 characters in a cell. So if that can be increased....
 
Upvote 0
Worf said:
The sample you sent me already had the parts after removing the letters on the end.
Therefore, this code ignores the ones that end with letters. Do you need the letters to be removed and the resulting part to remain there for processing?

uFoyw6z.png


<strike></strike>
Code: 
Sub Satv()                                          ' run me
Dim orig As Worksheet, aux As Worksheet, lr%, bsr As Range, i%
Set aux = Sheets("sheet1")                          ' auxiliary sheet
Set orig = Sheets("plan2")                          ' original sheet
orig.[d:d].ClearContents
orig.[d1] = "Result"
aux.Activate
Cells.ClearContents
orig.[a:a].Copy aux.[aa1]
[ab2].Formula = "=not(iserr(value(right(aa2,1))))"  ' no letter on the right side
Range("aa:aa").AdvancedFilter xlFilterCopy, [ab1:ab2], [a1], True
lr = Range("a" & Rows.Count).End(xlUp).Row
[b1] = "Len"
[b2].FormulaR1C1 = "=LEN(RC[-1])"
[b2].AutoFill Destination:=Range("B2:B" & lr), Type:=xlFillDefault
[c1] = [b1]
Range("b1:b" & lr).AdvancedFilter xlFilterCopy, [c1:c2], [d1], True
Set bsr = [e1]
For i = 2 To Range("d" & Rows.Count).End(xlUp).Row
    bsr.Offset(1).Formula = "=b2=" & Cells(i, 4)
    Range("a1:b" & lr).AdvancedFilter xlFilterCopy, bsr.Resize(2, 1), bsr.Offset(, 1), False
    DM bsr.Offset(1, 2), bsr.Offset(1, 1), bsr.Offset(1, 3)
    Range(Cells(2, bsr.Offset(, 3).Column), Cells(Range(Split(bsr.Offset(, 3).Address, "$")(1) _
    & Rows.Count).End(xlUp).Row, bsr.Offset(, 3).Column)).Copy _
    orig.Cells(orig.Range("d" & Rows.Count).End(xlUp).Row + 1, 4)
    Set bsr = bsr.Offset(, 4)
Next
End Sub

Sub DM(totrange As Range, dr As Range, dest As Range)
Dim a, lr, i&, d As Object, mn&, mx&, pref$, it, j%
Set d = CreateObject("Scripting.Dictionary")
lr = Range(Split(dr.Address, "$")(1) & Rows.Count).End(xlUp).Row
ReDim a(2 To lr)
j = 0
Do
    j = j + 1
Loop While Not IsNumeric(Mid(dr, j, 1)) And j < 20
j = j - 1
pref = Left(dr, j)
mx = 0
For i = 2 To lr
    a(i) = Right(Cells(i, dr.Column), Len(Cells(i, dr.Column)) - j)
    If i = 2 Then mn = a(i)
    If a(i) < mn Then mn = a(i)
    If a(i) > mx Then mx = a(i)
Next
For i = mn To mx
    it = pref & WorksheetFunction.Rept("0", totrange.Value - Len(pref & i)) & i
    d.Add it, it
Next
For i = 2 To lr
    If d.Exists(Cells(i, dr.Column).Value) Then d.Remove Cells(i, dr.Column).Value
Next
dest.Resize(d.Count).Value = WorksheetFunction.Transpose(d.Keys)
End Sub
Click to expand...

To sum up.

1. All the letter prefixes will be the same in each file, but the length of them will vary depending on the file I use it on.
2. Some cells will have letters on the end in varying lengths, and some may not in a file.

So if I have FASS12345ABC then FASS12347A the code has almost to forget there is letters on the end and tell me FASS12346 is missing.

I think from your example above that is what it may be doing in a way.

Thanks.
 
Last edited:
Upvote 0
If the lowest part number is FASS50000, should the missing list start with FASS00001 or FASS50001?
 
Upvote 0
Whatever the next number would be so if it starts FASS60000 then FASS60001
 
Upvote 0
All right, the letters on the end will be removed and the part will be processed.
I will be back soon.
 
Upvote 0
This seems to work:

GLTZCnW.png


Code: 
Dim prefix$
Sub Satv()                                          ' run me
Dim orig As Worksheet, aux As Worksheet, lr%, bsr As Range, i%, plen%
Application.ScreenUpdating = False
Set aux = Sheets("sheet1")                          ' auxiliary sheet
Set orig = Sheets("plan2")                          ' original sheet
orig.[d:d].ClearContents
orig.[d1] = "Result"
aux.Activate
Cells.ClearContents
orig.[a:a].Copy aux.[aa1]
lr = Range("aa" & Rows.Count).End(xlUp).Row
plen = [MIN(FIND({0,1,2,3,4,5,6,7,8,9},AA2&"0123456789"))] - 1
prefix = Left([aa2], plen)
Range("ac2:ac" & lr).Formula = "=right(aa2,len(aa2)-" & plen & ")"
Range("ad2:ad" & lr).Formula = "=min(find({1,2,3,4,5,6,7,8,9},ac2&""123456789""))-1"
NumPart Range("ae2:ae" & lr), "ac2"     ' extract numeric part
Range("ag2:ag" & lr).Formula = "=concatenate(""" & prefix & """,rept(""0"",ad2),ae2)"
[ag:ag].Copy
[a1].PasteSpecial xlPasteValues         ' original data,but no letters to the right
[a1] = "Data"
lr = Range("a" & Rows.Count).End(xlUp).Row
[b1] = "Len"
[b2].FormulaR1C1 = "=LEN(RC[-1])"
[b2].AutoFill Destination:=Range("B2:B" & lr), Type:=xlFillDefault
[c1] = [b1]
Range("b1:b" & lr).AdvancedFilter xlFilterCopy, [c1:c2], [d1], True
Set bsr = [e1]
For i = 2 To Range("d" & Rows.Count).End(xlUp).Row
    bsr.Offset(1).Formula = "=b2=" & Cells(i, 4)
    Range("a1:b" & lr).AdvancedFilter xlFilterCopy, bsr.Resize(2, 1), bsr.Offset(, 1), False
    DM bsr.Offset(1, 2), bsr.Offset(1, 1), bsr.Offset(1, 3)
    Range(Cells(2, bsr.Offset(, 3).Column), Cells(Range(Split(bsr.Offset(, 3).Address, "$")(1) _
    & Rows.Count).End(xlUp).Row, bsr.Offset(, 3).Column)).Copy _
    orig.Cells(orig.Range("d" & Rows.Count).End(xlUp).Row + 1, 4)
    Set bsr = bsr.Offset(, 5)
Next
Application.ScreenUpdating = True
End Sub

Sub DM(totrange As Range, dr As Range, dest As Range)
Dim a, lr, i&, d As Object, mn&, mx&, pref$, it, s$
Set d = CreateObject("Scripting.Dictionary")
lr = Range(Split(dr.Address, "$")(1) & Rows.Count).End(xlUp).Row
ReDim a(2 To lr)
mx = 0
NumPart Range(Cells(2, dest.Offset(, 1).Column), Cells(lr, dest.Offset(, 1).Column)), _
Split(dr.Address, "$")(1) & "2"
For i = 2 To lr
    a(i) = Cells(i, dest.Offset(, 1).Column)
    If i = 2 Then mn = a(i)
    If a(i) < mn Then mn = a(i)
    If a(i) > mx Then mx = a(i)
Next
For i = mn To mx
    it = prefix & WorksheetFunction.Rept("0", totrange.Value - Len(prefix & i)) & i
    d.Add it, it
Next
For i = 2 To lr
    If d.Exists(Cells(i, dr.Column).Value) Then d.Remove Cells(i, dr.Column).Value
Next
dest.Resize(d.Count).Value = WorksheetFunction.Transpose(d.Keys)
End Sub

Sub NumPart(r As Range, s$)
r.Formula = "=SUMPRODUCT(MID(0&" & s & ",LARGE(INDEX(ISNUMBER(--MID(" & s & _
",ROW(INDIRECT(""1:""&LEN(" & s & "))),1))*ROW(INDIRECT(""1:""&LEN(" & s & _
"))),0),ROW(INDIRECT(""1:""&LEN(" & s & "))))+1,1)*10^ROW(INDIRECT(""1:""&LEN(" & s & ")))/10)"
End Sub
 
Upvote 0
Thanks worf but I still don't seem to get the desired results. Plan2 sheet which has the result column it is missing the prefixes? And I take it sheet 1 is a helper sheet?
 
Upvote 0
You must log in or register to reply here.

Similar threads

M
  • Question Question
Help with FilterXML formula
Replies
0
Views
2K
montex01
M
E
  • Question Question
Would like to automate my spreadsheet.
Replies
9
Views
922
Fluff
Fluff
leopardhawk
  • Question Question
need help with DATEIF formula
Replies
8
Views
1K
leopardhawk
leopardhawk
D
  • Question Question
Removing spaces from cell with numbers
Replies
5
Views
1K
sandy666
sandy666
muhammad susanto
  • Question Question
Pull Data Based On Header
Replies
4
Views
988
mohadin
M

Forum statistics

Threads
1,224,827
Messages
6,181,194
Members
453,021
Latest member
pingpong7117

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top