Code To List Numbers Missing From Sequence

[Dazzawm]

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
4565	SS9822
4566	SS9824
4567	SS9826
4568	SS9828
4569	SS9830
4570	SS9831
4571	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>
</tbody>

​

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

Excel 2010

	D
4565	SS9823
4566	SS9825
4567	SS9827
4568	SS9829
4569	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>
</tbody>

​

Thanks

 

[Dazzawm]

I now get a box come up with a 400 in. And when I select ok sheet 1 ends up as below.

Excel 2010
	A	B	C
1	Plan2	5	5
2		0
sheet1

And plan2 is as below.

Excel 2010
	A	B	C	D
1	Plan2			Result
plan2

 

[Worf]

How many rows are there in column A? Can you email me the workbook?
I need to see the input data.

 

[Dazzawm]

How many rows are there in column A? Can you email me the workbook?
I need to see the input data.

Can you PM me your email please

 

[Worf]

There is data in the format SS2311XT.
Should the code ignore the letters on the right side?

 

[Dazzawm]

Yes, sorry I didn't realise they were in there

 

[Worf]

I will rewrite the code so that it removes the letters on the right.

 

[Worf]

• The parts after the letter removal were already there, so the code is simply excluding parts that end with letters.
• 5266 missing parts were found.
• Note that Sheet1 should be a blank sheet, while Plan2 holds the part list; of course these names can be changed.

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)
mn = 30000: mx = 0
For i = 2 To lr
    a(i) = Right(Cells(i, dr.Column), Len(Cells(i, dr.Column)) - j)
    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

 

[Dazzawm]

Thanks I will try at work tomorrow and let you know.

 

[Rick Rothstein]

I think the following macro will do what you want. Note that it assumes the same prefix for all values in Column A and that, since you did not say, the output will go to Column C (change the red letters to the column letter designation of the desired output column if different than my guess)...

Sub MissingNumbers()
  Dim X As Long, FirstNum As Long, LastNum As Long, PrefixLen As Long
  Dim PreFix As String, Nums As Variant, Data As Variant
  Data = Range("A2", Cells(Rows.Count, "A").End(xlUp))
  PrefixLen = [MIN(FIND({0,1,2,3,4,5,6,7,8,9},A2&"0123456789"))] - 1
  PreFix = Left(Data(1, 1), PrefixLen)
  FirstNum = Val(Mid(Data(1, 1), PrefixLen + 1))
  LastNum = Val(Mid(Data(UBound(Data), 1), PrefixLen + 1))
  Nums = Evaluate("ROW(1:" & LastNum & ")")
  For X = 1 To UBound(Data)
    If X < FirstNum Then
      Nums(X, 1) = ""
    Else
      Nums(Val(Mid(Data(X, 1), PrefixLen + 1)), 1) = ""
    End If
  Next
  Application.ScreenUpdating = False
  Range("[B][COLOR="#FF0000"]C[/COLOR][/B]1").Value = "Missing Nums"
  Range("[B][COLOR="#FF0000"]C[/COLOR][/B]2").Resize(UBound(Nums)) = Nums
  On Error GoTo Whoops
  With Range("[B][COLOR="#FF0000"]C[/COLOR][/B]2", Cells(Rows.Count, "[B][COLOR="#FF0000"]C[/COLOR][/B]").End(xlUp))
    .SpecialCells(xlBlanks).Delete xlShiftUp
    .Value = Evaluate("IF(" & .Address & "="""","""",""" & PreFix & """&TEXT(" & .Address & ",""000""))")
  End With
Whoops:
  Application.ScreenUpdating = True
End Sub

 

[Dazzawm]

Thanks Rick seems to work perfect. Thanks for all the time you have put into it also Worf. It seems to give some strange results in some columns but there is a column with the missing numbers. Its amazing with VBA how both codes are so different but in the end it gives you the same result. If I have any problems with any other files I use it on I will let you know. Thanks both again.