Find missing numbers in a range

[boboivan]

Hello everybody!

Currently I use the following VBA code to find missing numbers in a range ("C2:C3000"), worksheet "2014".

Sub MissingNumbers()Dim rng As Range
Dim rng1 As Range
Dim StartV As Single, EndV As Single, i As Single, j As Single
Dim k() As Single
Dim WS As Worksheet
ReDim k(0)
On Error Resume Next
Set rng = Range("C2:C3000")
StartV = InputBox("Start value:", , "4360201")
EndV = InputBox("End value:", , "4360")
On Error GoTo 0
Set WS = Sheets.Add
WS.Name = "MissingNumbers"
WS.Range("A1:A" & rng.Rows.CountLarge).Value = rng.Value
With WS.Sort
.SortFields.Add Key:=WS.Range("A1"), _
SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
.SetRange Range("A1:A" & rng.Rows.CountLarge)
.Header = xlNo
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
Set rng1 = WS.Range("A1:A" & rng.Rows.CountLarge)
For i = StartV To EndV
On Error Resume Next
j = Application.Match(i, rng1)
If Err = 0 Then
If rng1(j, 1) <> i Then
k(UBound(k)) = i
ReDim Preserve k(UBound(k) + 1)
End If
Else
k(UBound(k)) = i
ReDim Preserve k(UBound(k) + 1)
End If
On Error GoTo 0
Next i
ReDim Preserve k(UBound(k) - 1)
WS.Range("B1:B" & UBound(k) + 1) = Application.Transpose(k)
End Sub

The missing numbers are listed in a new sheet called ("MissingNumbers"), in range ("B1:B").

Please, could somebody help me with improving this code in order to:
1. add exceptions that wouldn't be listed as missing numbers (e.g. 4360241, 4360256, etc).
2. count the missing numbers at the end of the range ("B1:B") (in the first empty row, of course).
3. copy the missing numbers (with the count number) in the range ("AJ2:AJ") of the worksheet ("2014").

Thank you very much in advance!

[Bernie Deitrick]

1) Place the list of exceptions into a specific range - say sheet "Exceptions" column A. Then change

If rng1(j, 1) <> i Then
k(UBound(k)) = i
ReDim Preserve k(UBound(k) + 1)
End If

to

If rng1(j, 1) <> i Then
    If IsError(Application.Match(i, Worksheets("Exceptions").Range("A:A"), False)) Then
        k(UBound(k)) = i
        ReDim Preserve k(UBound(k) + 1)
    End If
End If

2) Add this line before End Sub

WS.Range("B" & UBound(k) + 1).Value = UBound(k)

3) And, add this line before End Sub

WS.Range("B1:B" & UBound(k) + 1).Copy Worksheets("2014").Range("AJ2")

[boboivan]

Thank you so much for the prompt answer!

Everything works perfect. You are a genius!

[Bernie Deitrick]

You modified the code incorrectly: I have changed the whole macro to reflect the changes, and made a few other changes. Let me know...

Sub MissingNumbers2()
    Dim rng As Range
    Dim rng1 As Range
    Dim StartV As Single, EndV As Single, i As Single, j As Single
    Dim k() As Single
    Dim WS As Worksheet
    
    ReDim k(0)
    
    On Error Resume Next
    Set rng = Range("C2:C3000")
    StartV = InputBox("Start value:", , "4360201")
    EndV = InputBox("End value:", , "4360")
    On Error GoTo 0
    
    Set WS = Sheets.Add
    WS.Name = "MissingNumbers"
    WS.Range("A1:A" & rng.Rows.CountLarge).Value = rng.Value
    With WS.Sort
        .SortFields.Add Key:=WS.Range("A1"), _
                        SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
        .SetRange Range("A1:A" & rng.Rows.CountLarge)
        .Header = xlNo
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    Set rng1 = WS.Range("A1:A" & rng.Rows.CountLarge)
    For i = StartV To EndV
        If IsError(Application.Match(i, rng1, False)) Then
            If IsError(Application.Match(i, Worksheets("List").Range("A:A"), False)) Then
                 k(UBound(k)) = i
                ReDim Preserve k(UBound(k) + 1)
            End If
        End If
    Next i
    WS.Range("B1:B" & UBound(k) + 1) = Application.Transpose(k)
    WS.Range("B" & UBound(k) + 1).Value = UBound(k)
    Worksheets("2014").Range("AJ2:AJ" & Rows.CountLarge).ClearContents
    WS.Range("B1:B" & UBound(k) + 1).Copy Worksheets("2014").Range("AJ2")
    
End Sub

[boboivan]

Yes sir, you're right!
I missed to add a line in the code. I noticed that after I replied to you, and therefore I edited the reply .
Regarding the new code, everything works great, except of refreshing range "AJ:AJ" in worksheet "2014" with the new values, every time I re-run the macro after making changes in my registrations or the list of exceptions.

And now I noticed that is missing the line

WS.Range("B1:B" & UBound(k) + 1).Copy Worksheets("2014").Range("AJ2")

in the new code . So everything is perfect.

Thank you again, you genius!

[Bernie Deitrick]

I forgot to add this line to the second version:

WS.Range("B1:B" & UBound(k) + 1).Copy Worksheets("2014").Range("AJ2")

But it should be changed anyway, to clear out the old values

Worksheets("2014").Range("AJ2:AJ" & Rows.CountLarge).ClearContents
WS.Range("B1:B" & UBound(k) + 1).Copy Worksheets("2014").Range("AJ2")

[boboivan]

Yeah, now is totally perfect!

I was thinking last night if the code could be improved so as to display the missing numbers from range B:B, sheet ("2014") directly to range AJ:AJ, sheet ("2014"), without creating a new sheet ("MissingNumbers").

Do you think is this possible? Thx again and sorry for the trouble.

Meanwhile, I found a solution which works ok, but I don't think it's a very elegant one. What do you think of it?

Sub MissingNumbers2()
    Dim rng As Range
    Dim rng1 As Range
    Dim StartV As Single, EndV As Single, i As Single, j As Single
    Dim k() As Single
    Dim WS As Worksheet
    
    ReDim k(0)
    
    On Error Resume Next
    Set rng = Range("C2:C3000")
    StartV = InputBox("Start value:", , "4360201")
    EndV = InputBox("End value:", , "4360")
    On Error GoTo 0
    
    Set WS = Sheets.Add
    WS.Name = "MissingNumbers"
    WS.Range("A1:A" & rng.Rows.CountLarge).Value = rng.Value
    With WS.Sort
        .SortFields.Add Key:=WS.Range("A1"), _
                        SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
        .SetRange Range("A1:A" & rng.Rows.CountLarge)
        .Header = xlNo
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    Set rng1 = WS.Range("A1:A" & rng.Rows.CountLarge)
    For i = StartV To EndV
        If IsError(Application.Match(i, rng1, False)) Then
            If IsError(Application.Match(i, Worksheets("List").Range("A:A"), False)) Then
                 k(UBound(k)) = i
                ReDim Preserve k(UBound(k) + 1)
            End If
        End If
    Next i
    WS.Range("B1:B" & UBound(k) + 1) = Application.Transpose(k)
    WS.Range("B" & UBound(k) + 1).Value = UBound(k)
    Worksheets("2014").Range("AJ2:AJ" & Rows.CountLarge).ClearContents
    WS.Range("B1:B" & UBound(k) + 1).Copy Worksheets("2014").Range("AJ2")
    Application.DisplayAlerts = False
    WS.Delete
    
End Sub