Code To List Numbers Missing From Sequence

Dazzawm

Well-known Member
Joined
Jan 24, 2011
Messages
3,398
Office Version
2016
Platform
Windows
Would you PM me your email again please.
 

Some videos you may like

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.

Worf

Well-known Member
Joined
Oct 30, 2011
Messages
3,969
I tested the code from post 62 with the two data sets you provided and it completed without errors.
I am sending my test workbook back to you; try it on two different machines if possible.
 

Worf

Well-known Member
Joined
Oct 30, 2011
Messages
3,969
This is the version I have on my personal macro workbook. I brought up the macro dialog box with Alt+F8 and executed it from the test workbook, which was the only file open. It worked correctly.

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:=0
[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 2, 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
 

Dazzawm

Well-known Member
Joined
Jan 24, 2011
Messages
3,398
Office Version
2016
Platform
Windows
This is the version I have on my personal macro workbook. I brought up the macro dialog box with Alt+F8 and executed it from the test workbook, which was the only file open. It worked correctly.

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:=0
[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 2, 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
Working much better now, thanks for all your time.
 

Dazzawm

Well-known Member
Joined
Jan 24, 2011
Messages
3,398
Office Version
2016
Platform
Windows
Worf I am now getting a run-time error '13' type mismatch and when I debug it points to this line?

dest.Resize(d.Count).Value = WorksheetFunction.Transpose(d.Keys)
 
Last edited:

Worf

Well-known Member
Joined
Oct 30, 2011
Messages
3,969
As before, I need the input data that generates the error, either here or via email.
 

Dazzawm

Well-known Member
Joined
Jan 24, 2011
Messages
3,398
Office Version
2016
Platform
Windows
Seems to have been a rogue character messing it up.
 

Watch MrExcel Video

Forum statistics

Threads
1,099,329
Messages
5,467,974
Members
406,561
Latest member
Grappledog

This Week's Hot Topics

Top