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

Workdays for a market open Mon, Wed, Friday?
Yes! Use "0101011" for the weekend argument in NETWORKDAYS.INTL or WORKDAY.INTL. The 7 digits start on Monday. 1 means it is a weekend.

Worf

Well-known Member
Joined
Oct 30, 2011
Messages
4,004
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
4,004
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
4,004
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,102,782
Messages
5,488,850
Members
407,658
Latest member
Arias610

This Week's Hot Topics

  • Timer in VBA - Stop, Start, Pause and Reset
    [CODE=vba][/CODE] Option Explicit Dim CmdStop As Boolean Dim Paused As Boolean Dim Start Dim TimerValue As Date Dim pausedTime As Date Sub...
  • how to updates multiple rows in muliselect listbox
    Hello everyone. I need help with below code. code is only chaning 1st row in mulitiselect list box. i know issue with code...
  • Delete Row from Table
    I am trying to delete a row from a table using VBA using a named range to find what I need to delete. My Range is finding the right cell. In the...
  • Assigning to a variable
    I have a for each block where I want to assign the value in column 5 of the found row to the variable Serv. [CODE=vba] For Each ws In...
  • Way to verify information
    Hi All, I don't know what to call this formula, and therefore can't search. I have a spreadsheet with information I want to reference...
  • Active Cell Address – Inactive Sheet
    How to use VBA to get the cell address of the active cell in an inactive worksheet and then place that cell address in a location on the current...
Top