Missing Sequential Numbers

[Ozzie via OfficeKB.com]

Guys,

I have a spreadsheet which is basically a table of data, which is a log of
discount vouchers received, with the first column being a sequential number.

I need to be able to determine when there is a break in these numbers and
provide a list of those missing.

ie if I had a list of numbers 65000, 65001, 65002, 65005,

then a list would be produced, maybe a pop up form, with 65003 and 65004 as
those are missing.

issue 1 - the blocks of sequential numbers can diff, ie 1 block of numbers
might be from 20000 to 30000 another maybe 65000 to 80000 etc.
issue 2 - occassionally I get a duplicate, number due to user error!.

Anybody any ideas how to tackle this ?

Many, many, thanks

Cheers

David

 

[tony h]

Depends really what you want to do:

a. if you want to do it in code than set up an integer array
dimensioned from the lowest value to the highest value. Then run
through the table add 1 using the value as an index to the array.
A value of 0 in an element of the array will indicate that it is
missing, a value of one that it occurs once and more than one indicates
duplicates.

2. if you want to do it on a spreadsheet. Then set up a table in the
same way. first cell is lowest value, Next cells are if lastcell+1 <
Max value then lastcell+1 else "". then in next column do a countA to
get number of occurances. A quick scan down the list will show where
there are problems.

Let us know what you want to do and I may post some code.

regards

 

[Ozzie via OfficeKB.com]

Hi Tony,

I need to do it in code.

Would the code be able to determine the missing numbers? ie if we had 65002
and 65005 would it produce the missing 65003 and 65004 or would it say that 2
number are missing? the first option is preferable.

Cheers for your help,

 

[Guest]

Hi,
Try this. Assumes sequence numbers in column A and outputs
Missing/duplicates in Columns A and B of second worksheet


Sub FindMissingAndDuplicates()

Dim ws1 As Worksheet, ws2 As Worksheet
Dim v() As Long, missing() As Long, i As Long, lastrow As Long

sblock = Application.InputBox("Enter block start")
fblock = Application.InputBox("Enter block end")


ReDim v(fblock - sblock + 1)

j = 0
For i = sblock To fblock
v(j) = i
j = j + 1
Next i
Set ws1 = Worksheets("sheet1")
Set ws2 = Worksheets("sheet2")
ws2.Range("a1:b1") = Array("Missing", "Duplicated")

With ws1
lastrow = .Cells(Rows.Count, 1).End(xlUp).Row
Set rng = .Range("a1:a" & lastrow)
End With

n1 = 2
n2 = 2
For i = LBound(v) To UBound(v)
If IsError(Application.Match(v(i), rng, 0)) Then
ws2.Cells(n1, 1) = v(i)
n1 = n1 + 1
Else
If Application.CountIf(rng, v(i)) > 1 Then
ws2.Cells(n2, 2) = v(i)
n2 = n2 + 1
End If
End If
Next i
End Sub

 

[bplumhoff]

Hi David,

Try

Option Explicit

Sub missing_numbers()
Dim ri As Range
Dim lmin As Long, lmax As Long, i As Long, j As Long, lrow As Long
Dim coll As New Collection

lmin = 2000000000
lmax = -2000000000
Range("B:B").ClearContents
For Each ri In Range("A:A")
If Not IsEmpty(ri) Then
If ri.Value > lmax Then lmax = ri.Value
If ri.Value < lmin Then lmin = ri.Value
coll.Add 0, "X" & ri
End If
Next ri

On Error Resume Next
lrow = 1
For i = lmin To lmax
Err.Clear
j = coll("X" & i)
If Err.Number <> 0 Then
Cells(lrow, 2).Formula = i
lrow = lrow + 1
End If
Next i

End Sub

This macro reads numbers in column A and writes missing numbers into
column B.

HTH,
Bernd

 

[Tom Ogilvy]

Select the cells you want to check and run this macro:

Sub FindMissing()
Dim lStart As Long
Dim s As String, d As String
Dim cell As Range
lStart = Selection(1).Value
For Each cell In Selection
If cell.Value <> cell.Offset(1, 0).Value Then
If lStart < cell.Value Then
Do
s = s & lStart & vbNewLine
lStart = lStart + 1
Loop Until lStart = cell.Value
End If
lStart = lStart + 1

Else
d = d & cell.Value & vbNewLine
End If
Next
If Len(s) > 0 Then
MsgBox "Missing Numbers: " & _
vbNewLine & s
Else
MsgBox "No missing numbers"
End If
If Len(d) > 0 Then
MsgBox "Duplicates: " & _
vbNewLine & d
End If
End Sub

 

[Guest]

An update: the Match statement could be replaced with:

If Application.CountIf(rng, v(i)) = 0 Then
.......

I believe COUNTIF executes quicker than MATCH.

 

[Ozzie via OfficeKB.com]

Many thanks for all the responses, I give them all a try and let you know,

thanks again

David

An update: the Match statement could be replaced with:

If Application.CountIf(rng, v(i)) = 0 Then
......

I believe COUNTIF executes quicker than MATCH.

Hi Tony,

[quoted text clipped - 24 lines]

 

[Ozzie via OfficeKB.com]

Toppers,

Great stuff, works a treat, but just 1 little thing!,

Is it possible not to have ref to a sheet name as with "Set ws1 = Worksheets
("sheet1")" because my sheet name will always change?

Cheers,

David

Hi,
Try this. Assumes sequence numbers in column A and outputs
Missing/duplicates in Columns A and B of second worksheet

Sub FindMissingAndDuplicates()

Dim ws1 As Worksheet, ws2 As Worksheet
Dim v() As Long, missing() As Long, i As Long, lastrow As Long

sblock = Application.InputBox("Enter block start")
fblock = Application.InputBox("Enter block end")

ReDim v(fblock - sblock + 1)

j = 0
For i = sblock To fblock
v(j) = i
j = j + 1
Next i
Set ws1 = Worksheets("sheet1")
Set ws2 = Worksheets("sheet2")
ws2.Range("a1:b1") = Array("Missing", "Duplicated")

With ws1
lastrow = .Cells(Rows.Count, 1).End(xlUp).Row
Set rng = .Range("a1:a" & lastrow)
End With

n1 = 2
n2 = 2
For i = LBound(v) To UBound(v)
If IsError(Application.Match(v(i), rng, 0)) Then
ws2.Cells(n1, 1) = v(i)
n1 = n1 + 1
Else
If Application.CountIf(rng, v(i)) > 1 Then
ws2.Cells(n2, 2) = v(i)
n2 = n2 + 1
End If
End If
Next i
End Sub

Hi Tony,

[quoted text clipped - 24 lines]

 

[tony h]

Option Explicit

Sub a()
Dim rng As Range
Dim r As Range
Dim iA() As Integer
Dim iMin As Integer
Dim iMAx As Integer

Dim i As Integer
Dim strMissing As String
Dim strDupes As String

Set rng = Range("A1:A14")
iMin = Application.WorksheetFunction.Min(rng)
iMAx = Application.WorksheetFunction.Max(rng)

ReDim iA(iMin To iMAx)
For Each r In rng
iA(r) = iA(r) + 1
Next


For i = iMin To iMAx
Select Case iA(i)
Case Is > 1
strDupes = strDupes & CStr(i) & ", "
Case Is = 0
strMissing = strMissing & CStr(i) & ", "
End Select
Next
MsgBox "duplicates are : " & strDupes
MsgBox "missing are : " & strMissing


End Su

 

[Guest]

Hi,

Use "With activesheet" but make sure it is the active sheet when you run!

And a slightly tidier version:

Sub FindMissingAndDuplicates()

Dim ws1 As Worksheet, ws2 As Worksheet
Dim v() As Long, missing() As Long, i As Long, lastrow As Long

sblock = Application.InputBox("Enter block start")
fblock = Application.InputBox("Enter block end")


ReDim v(1 To fblock - sblock + 1)

j = 0
For i = sblock To fblock
j = j + 1
v(j) = i
Next i

Set ws1 = Worksheets("sheet1")
Set ws2 = Worksheets("sheet2")
ws2.Range("a1:b1") = Array("Missing", "Duplicated")

With ActiveSheet
lastrow = .Cells(Rows.Count, 1).End(xlUp).Row
Set rng = .Range("a1:a" & lastrow)
End With

n1 = 2
n2 = 2
For i = LBound(v) To UBound(v)
num = Application.CountIf(rng, v(i))
Select Case num
Case Is = 0
ws2.Cells(n1, 1) = v(i)
n1 = n1 + 1
Case Is > 1
ws2.Cells(n2, 2) = v(i)
n2 = n2 + 1
End Select
Next i
End Sub

Toppers,

Great stuff, works a treat, but just 1 little thing!,

Is it possible not to have ref to a sheet name as with "Set ws1 = Worksheets
("sheet1")" because my sheet name will always change?

Cheers,

David

Hi,
Try this. Assumes sequence numbers in column A and outputs
Missing/duplicates in Columns A and B of second worksheet

Sub FindMissingAndDuplicates()

Dim ws1 As Worksheet, ws2 As Worksheet
Dim v() As Long, missing() As Long, i As Long, lastrow As Long

sblock = Application.InputBox("Enter block start")
fblock = Application.InputBox("Enter block end")

ReDim v(fblock - sblock + 1)

j = 0
For i = sblock To fblock
v(j) = i
j = j + 1
Next i
Set ws1 = Worksheets("sheet1")
Set ws2 = Worksheets("sheet2")
ws2.Range("a1:b1") = Array("Missing", "Duplicated")

With ws1
lastrow = .Cells(Rows.Count, 1).End(xlUp).Row
Set rng = .Range("a1:a" & lastrow)
End With

n1 = 2
n2 = 2
For i = LBound(v) To UBound(v)
If IsError(Application.Match(v(i), rng, 0)) Then
ws2.Cells(n1, 1) = v(i)
n1 = n1 + 1
Else
If Application.CountIf(rng, v(i)) > 1 Then
ws2.Cells(n2, 2) = v(i)
n2 = n2 + 1
End If
End If
Next i
End Sub

Hi Tony,

[quoted text clipped - 24 lines]

regards

 

[Ozzie via OfficeKB.com]

Hi Toppers, thanks for th enew code, works great.

would you mind me making a slight amendment, as the way I want it to work has
slightly changed.

My spreadsheet has many sheets, Sheet 1 called "Derby", sheet 2 called
"Sheffield" etc with a Sheet called "Voucher Descrep".

If I run the macro from each individual sheet, is it possible to show all the
results on one sheet,

So we would see on the "voucher Descrep" sheet

Columns A:C would be column A- "Derby" (Sheet Name) column B "missing" and
column C "duplicated" and miss a column then Columns E:G would be column E-
"Sheffield" (Sheet Name) column F "missing" and column G "duplicated" etc,

sorry not to have been more clearer from the start,

Thanks for your help so far,

Cheers

David

Hi,

Use "With activesheet" but make sure it is the active sheet when you run!

And a slightly tidier version:

Sub FindMissingAndDuplicates()

Dim ws1 As Worksheet, ws2 As Worksheet
Dim v() As Long, missing() As Long, i As Long, lastrow As Long

sblock = Application.InputBox("Enter block start")
fblock = Application.InputBox("Enter block end")

ReDim v(1 To fblock - sblock + 1)

j = 0
For i = sblock To fblock
j = j + 1
v(j) = i
Next i

Set ws1 = Worksheets("sheet1")
Set ws2 = Worksheets("sheet2")
ws2.Range("a1:b1") = Array("Missing", "Duplicated")

With ActiveSheet
lastrow = .Cells(Rows.Count, 1).End(xlUp).Row
Set rng = .Range("a1:a" & lastrow)
End With

n1 = 2
n2 = 2
For i = LBound(v) To UBound(v)
num = Application.CountIf(rng, v(i))
Select Case num
Case Is = 0
ws2.Cells(n1, 1) = v(i)
n1 = n1 + 1
Case Is > 1
ws2.Cells(n2, 2) = v(i)
n2 = n2 + 1
End Select
Next i
End Sub

Toppers,

[quoted text clipped - 55 lines]

 

[Guest]

Are the all the sheets in the workbook, except "Voucher Descrp" to be
processed? I need to know have many sheets so I can work out where to place
the data.

Hi Toppers, thanks for th enew code, works great.

would you mind me making a slight amendment, as the way I want it to work has
slightly changed.

My spreadsheet has many sheets, Sheet 1 called "Derby", sheet 2 called
"Sheffield" etc with a Sheet called "Voucher Descrep".

If I run the macro from each individual sheet, is it possible to show all the
results on one sheet,

So we would see on the "voucher Descrep" sheet

Columns A:C would be column A- "Derby" (Sheet Name) column B "missing" and
column C "duplicated" and miss a column then Columns E:G would be column E-
"Sheffield" (Sheet Name) column F "missing" and column G "duplicated" etc,

sorry not to have been more clearer from the start,

Thanks for your help so far,

Cheers

David

Hi,

Use "With activesheet" but make sure it is the active sheet when you run!

And a slightly tidier version:

Sub FindMissingAndDuplicates()

Dim ws1 As Worksheet, ws2 As Worksheet
Dim v() As Long, missing() As Long, i As Long, lastrow As Long

sblock = Application.InputBox("Enter block start")
fblock = Application.InputBox("Enter block end")

ReDim v(1 To fblock - sblock + 1)

j = 0
For i = sblock To fblock
j = j + 1
v(j) = i
Next i

Set ws1 = Worksheets("sheet1")
Set ws2 = Worksheets("sheet2")
ws2.Range("a1:b1") = Array("Missing", "Duplicated")

With ActiveSheet
lastrow = .Cells(Rows.Count, 1).End(xlUp).Row
Set rng = .Range("a1:a" & lastrow)
End With

n1 = 2
n2 = 2
For i = LBound(v) To UBound(v)
num = Application.CountIf(rng, v(i))
Select Case num
Case Is = 0
ws2.Cells(n1, 1) = v(i)
n1 = n1 + 1
Case Is > 1
ws2.Cells(n2, 2) = v(i)
n2 = n2 + 1
End Select
Next i
End Sub

Toppers,

[quoted text clipped - 55 lines]

regards

 

[Ozzie via OfficeKB.com]

Yes, all sheets except "voucher Descrp" and "sheet1" (sheet1 holds all master
data)

There are currently 9 sheets which will grow to 15.

Cheers

Are the all the sheets in the workbook, except "Voucher Descrp" to be
processed? I need to know have many sheets so I can work out where to place
the data.

Hi Toppers, thanks for th enew code, works great.

[quoted text clipped - 72 lines]

 

[Guest]

Hi,
Checks all sheets EXCEPT "Voucher Descrp".

Sub FindMissingAndDuplicates()

Dim ws1 As Worksheet, ws2 As Worksheet
Dim v() As Long, i As Long, lastrow As Long
Dim ws2rng As Range

sblock = Application.InputBox("Enter block start")
fblock = Application.InputBox("Enter block end")


ReDim v(1 To fblock - sblock + 1)

j = 0
For i = sblock To fblock
j = j + 1
v(j) = i
Next i

Set ws2 = Worksheets("Voucher Descrp")
ws2.Cells.ClearContents

ncol = 1

For Each sh In ThisWorkbook.Sheets

If sh.Name <> "Voucher Descrp" Then

Set ws2rng = ws2.Cells(1, ncol)

ws2rng = sh.Name
ws2rng.Offset(0, 1).Resize(1, 2) = Array("Missing", "Duplicated")

sh.Activate
lastrow = Cells(Rows.Count, 1).End(xlUp).Row
Set rng = Range("a1:a" & lastrow)

n1 = 2
n2 = 2
For i = LBound(v) To UBound(v)
num = Application.CountIf(rng, v(i))
Select Case num
Case Is = 0
ws2.Cells(n1, ncol + 1) = v(i)
n1 = n1 + 1
Case Is > 1
ws2.Cells(n2, ncol + 2) = v(i)
n2 = n2 + 1
End Select
Next i
End If

ncol = ncol + 4

Next sh

End Sub

Are the all the sheets in the workbook, except "Voucher Descrp" to be
processed? I need to know have many sheets so I can work out where to place
the data.

Hi Toppers, thanks for th enew code, works great.

would you mind me making a slight amendment, as the way I want it to work has
slightly changed.

My spreadsheet has many sheets, Sheet 1 called "Derby", sheet 2 called
"Sheffield" etc with a Sheet called "Voucher Descrep".

If I run the macro from each individual sheet, is it possible to show all the
results on one sheet,

So we would see on the "voucher Descrep" sheet

Columns A:C would be column A- "Derby" (Sheet Name) column B "missing" and
column C "duplicated" and miss a column then Columns E:G would be column E-
"Sheffield" (Sheet Name) column F "missing" and column G "duplicated" etc,

sorry not to have been more clearer from the start,

Thanks for your help so far,

Cheers

David

Hi,

Use "With activesheet" but make sure it is the active sheet when you run!

And a slightly tidier version:

Sub FindMissingAndDuplicates()

Dim ws1 As Worksheet, ws2 As Worksheet
Dim v() As Long, missing() As Long, i As Long, lastrow As Long

sblock = Application.InputBox("Enter block start")
fblock = Application.InputBox("Enter block end")

ReDim v(1 To fblock - sblock + 1)

j = 0
For i = sblock To fblock
j = j + 1
v(j) = i
Next i

Set ws1 = Worksheets("sheet1")
Set ws2 = Worksheets("sheet2")
ws2.Range("a1:b1") = Array("Missing", "Duplicated")

With ActiveSheet
lastrow = .Cells(Rows.Count, 1).End(xlUp).Row
Set rng = .Range("a1:a" & lastrow)
End With

n1 = 2
n2 = 2
For i = LBound(v) To UBound(v)
num = Application.CountIf(rng, v(i))
Select Case num
Case Is = 0
ws2.Cells(n1, 1) = v(i)
n1 = n1 + 1
Case Is > 1
ws2.Cells(n2, 2) = v(i)
n2 = n2 + 1
End Select
Next i
End Sub

Toppers,

[quoted text clipped - 55 lines]

regards

 

[Guest]

Change previous code to:

If sh.Name <> "Voucher Descrp" And sh.Name <> "Sheet1" Then

Hi,
Checks all sheets EXCEPT "Voucher Descrp".

Sub FindMissingAndDuplicates()

Dim ws1 As Worksheet, ws2 As Worksheet
Dim v() As Long, i As Long, lastrow As Long
Dim ws2rng As Range

sblock = Application.InputBox("Enter block start")
fblock = Application.InputBox("Enter block end")


ReDim v(1 To fblock - sblock + 1)

j = 0
For i = sblock To fblock
j = j + 1
v(j) = i
Next i

Set ws2 = Worksheets("Voucher Descrp")
ws2.Cells.ClearContents

ncol = 1

For Each sh In ThisWorkbook.Sheets

If sh.Name <> "Voucher Descrp" Then

Set ws2rng = ws2.Cells(1, ncol)

ws2rng = sh.Name
ws2rng.Offset(0, 1).Resize(1, 2) = Array("Missing", "Duplicated")

sh.Activate
lastrow = Cells(Rows.Count, 1).End(xlUp).Row
Set rng = Range("a1:a" & lastrow)

n1 = 2
n2 = 2
For i = LBound(v) To UBound(v)
num = Application.CountIf(rng, v(i))
Select Case num
Case Is = 0
ws2.Cells(n1, ncol + 1) = v(i)
n1 = n1 + 1
Case Is > 1
ws2.Cells(n2, ncol + 2) = v(i)
n2 = n2 + 1
End Select
Next i
End If

ncol = ncol + 4

Next sh

End Sub

Are the all the sheets in the workbook, except "Voucher Descrp" to be
processed? I need to know have many sheets so I can work out where to place
the data.

Hi Toppers, thanks for th enew code, works great.

would you mind me making a slight amendment, as the way I want it to work has
slightly changed.

My spreadsheet has many sheets, Sheet 1 called "Derby", sheet 2 called
"Sheffield" etc with a Sheet called "Voucher Descrep".

If I run the macro from each individual sheet, is it possible to show all the
results on one sheet,

So we would see on the "voucher Descrep" sheet

Columns A:C would be column A- "Derby" (Sheet Name) column B "missing" and
column C "duplicated" and miss a column then Columns E:G would be column E-
"Sheffield" (Sheet Name) column F "missing" and column G "duplicated" etc,

sorry not to have been more clearer from the start,

Thanks for your help so far,

Cheers

David



Toppers wrote:
Hi,

Use "With activesheet" but make sure it is the active sheet when you run!

And a slightly tidier version:

Sub FindMissingAndDuplicates()

Dim ws1 As Worksheet, ws2 As Worksheet
Dim v() As Long, missing() As Long, i As Long, lastrow As Long

sblock = Application.InputBox("Enter block start")
fblock = Application.InputBox("Enter block end")

ReDim v(1 To fblock - sblock + 1)

j = 0
For i = sblock To fblock
j = j + 1
v(j) = i
Next i

Set ws1 = Worksheets("sheet1")
Set ws2 = Worksheets("sheet2")
ws2.Range("a1:b1") = Array("Missing", "Duplicated")

With ActiveSheet
lastrow = .Cells(Rows.Count, 1).End(xlUp).Row
Set rng = .Range("a1:a" & lastrow)
End With

n1 = 2
n2 = 2
For i = LBound(v) To UBound(v)
num = Application.CountIf(rng, v(i))
Select Case num
Case Is = 0
ws2.Cells(n1, 1) = v(i)
n1 = n1 + 1
Case Is > 1
ws2.Cells(n2, 2) = v(i)
n2 = n2 + 1
End Select
Next i
End Sub

Toppers,

[quoted text clipped - 55 lines]

regards

 

[Ozzie via OfficeKB.com]

Hi Toppers, sorry to be a pain but did you get any joy with this ?

Are the all the sheets in the workbook, except "Voucher Descrp" to be
processed? I need to know have many sheets so I can work out where to place
the data.

Hi Toppers, thanks for th enew code, works great.

[quoted text clipped - 72 lines]

 

[Guest]

See my repies yesterday which supplied code to go through each sheet.

Hi Toppers, sorry to be a pain but did you get any joy with this ?

Are the all the sheets in the workbook, except "Voucher Descrp" to be
processed? I need to know have many sheets so I can work out where to place
the data.

Hi Toppers, thanks for th enew code, works great.

[quoted text clipped - 72 lines]

regards

 

[Ozzie via OfficeKB.com]

Hiya Topper,

I have tried the new code but had a few problems. The code checks all sheets
in 1 go, but it isn't possible to enter all the ranges in 1 go.

Is it poss to check each sheet individually but still place the results in
columns following on ? like the code currently does.

if its easier i don't mind sending you the spreadsheet i'm working with?

thanks for oyour help,

David

Hi,

Use "With activesheet" but make sure it is the active sheet when you run!

And a slightly tidier version:

Sub FindMissingAndDuplicates()

Dim ws1 As Worksheet, ws2 As Worksheet
Dim v() As Long, missing() As Long, i As Long, lastrow As Long

sblock = Application.InputBox("Enter block start")
fblock = Application.InputBox("Enter block end")

ReDim v(1 To fblock - sblock + 1)

j = 0
For i = sblock To fblock
j = j + 1
v(j) = i
Next i

Set ws1 = Worksheets("sheet1")
Set ws2 = Worksheets("sheet2")
ws2.Range("a1:b1") = Array("Missing", "Duplicated")

With ActiveSheet
lastrow = .Cells(Rows.Count, 1).End(xlUp).Row
Set rng = .Range("a1:a" & lastrow)
End With

n1 = 2
n2 = 2
For i = LBound(v) To UBound(v)
num = Application.CountIf(rng, v(i))
Select Case num
Case Is = 0
ws2.Cells(n1, 1) = v(i)
n1 = n1 + 1
Case Is > 1
ws2.Cells(n2, 2) = v(i)
n2 = n2 + 1
End Select
Next i
End Sub

Toppers,

[quoted text clipped - 55 lines]

 

[Guest]

Hi,
Yes ... send to "(e-mail address removed)" with clear
explanation of how you want it to work. I did suspect you would want to enter
a block per sheet, rather than one block for all - and it makes sense!:
that's easy to change. Could there be more than one block per sheet?

Hiya Topper,

I have tried the new code but had a few problems. The code checks all sheets
in 1 go, but it isn't possible to enter all the ranges in 1 go.

Is it poss to check each sheet individually but still place the results in
columns following on ? like the code currently does.

if its easier i don't mind sending you the spreadsheet i'm working with?

thanks for oyour help,

David

Hi,

Use "With activesheet" but make sure it is the active sheet when you run!

And a slightly tidier version:

Sub FindMissingAndDuplicates()

Dim ws1 As Worksheet, ws2 As Worksheet
Dim v() As Long, missing() As Long, i As Long, lastrow As Long

sblock = Application.InputBox("Enter block start")
fblock = Application.InputBox("Enter block end")

ReDim v(1 To fblock - sblock + 1)

j = 0
For i = sblock To fblock
j = j + 1
v(j) = i
Next i

Set ws1 = Worksheets("sheet1")
Set ws2 = Worksheets("sheet2")
ws2.Range("a1:b1") = Array("Missing", "Duplicated")

With ActiveSheet
lastrow = .Cells(Rows.Count, 1).End(xlUp).Row
Set rng = .Range("a1:a" & lastrow)
End With

n1 = 2
n2 = 2
For i = LBound(v) To UBound(v)
num = Application.CountIf(rng, v(i))
Select Case num
Case Is = 0
ws2.Cells(n1, 1) = v(i)
n1 = n1 + 1
Case Is > 1
ws2.Cells(n2, 2) = v(i)
n2 = n2 + 1
End Select
Next i
End Sub

Toppers,

[quoted text clipped - 55 lines]

regards