Hi

Looking for macro code to delete duplicates based on column B. First I
think the data needs to be sorted so the dups are under each other and then
delete the dups.
thanks for the help
--
Mike B

Here is some code that I use to generate lists of unique items or lists of
duplicated items (the lists show up in their own new sheet). To run the code
select column B and then run GetUniqueItems. You should paste this code into
a module and reference that module to "Microsoft Scripting Runtime".

Option Explicit

Private Sub GetUniqueItems()
Dim cell As Range 'Current cell in range to check
Dim rngToSearch As Range 'Cells to be searched
Dim dic As Scripting.Dictionary 'Dictionary Object
Dim dicItem As Variant 'Items within dictionary object
Dim wks As Worksheet 'Worksheet to populate with
unique items
Dim rngPaste As Range 'Cells where unique items are
placed

'Create range to be searched
Set rngToSearch = Intersect(ActiveSheet.UsedRange, Selection)

'Confirm there is a relevant range selected
If Not rngToSearch Is Nothing Then
'Create dictionay object
Set dic = New Scripting.Dictionary

'Populate dictionary object with unique items (use key to define
unique)
For Each cell In rngToSearch 'Traverse selected range
If Not dic.Exists(cell.Value) Then 'Check the key
dic.Add cell.Value, cell.Value 'Add the item if unique
End If
Next

If Not dic Is Nothing Then 'Check for dictionary
Set wks = Worksheets.Add 'Create worksheet to populate
Set rngPaste = wks.Range("A1") 'Create range to populate
For Each dicItem In dic.Items 'Loop through dictionary
rngPaste.NumberFormat = "@" 'Format cell as text
rngPaste.Value = dicItem 'Add items to new sheet
Set rngPaste = rngPaste.Offset(1, 0) 'Increment paste range
Next dicItem
'Clean up objects
Set wks = Nothing
Set rngPaste = Nothing
Set dic = Nothing
End If
End If
End Sub

Private Sub GetDuplicateItems()
Dim cell As Range 'Current cell in range to check
Dim rngToSearch As Range 'Cells to be searched
Dim dic As Scripting.Dictionary 'Dictionary Object
Dim dicItem As Variant 'Items within dictionary object
Dim wks As Worksheet 'Worksheet to populate with
unique items
Dim rngPaste As Range 'Cells where unique items are
placed
Dim aryDuplicates() As String
Dim lngCounter As Long

'Create range to be searched
Set rngToSearch = Intersect(ActiveSheet.UsedRange, Selection)
lngCounter = 0

'Confirm there is a relevant range selected
If Not rngToSearch Is Nothing Then
'Create dictionay object
Set dic = New Scripting.Dictionary

'Populate dictionary object with unique items (use key to define
unique)
For Each cell In rngToSearch 'Traverse selected range
If Not dic.Exists(cell.Value) Then 'Check the key
dic.Add cell.Value, cell.Value 'Add the item if unique
Else
ReDim Preserve aryDuplicates(lngCounter)
aryDuplicates(lngCounter) = cell
lngCounter = lngCounter + 1
End If
Next

If lngCounter 0 Then 'Check for values
Set wks = Worksheets.Add 'Create worksheet to populate
Set rngPaste = wks.Range("A1") 'Create range to populate
For lngCounter = LBound(aryDuplicates) To UBound(aryDuplicates)
'Loop duplicates
rngPaste.NumberFormat = "@" 'Format cell as text
rngPaste.Value = aryDuplicates(lngCounter) 'Add items to
new sheet
Set rngPaste = rngPaste.Offset(1, 0) 'Increment paste range
Next lngCounter
'Clean up objects
Set wks = Nothing
Set rngPaste = Nothing
Else
MsgBox "There are no duplicate items in the selected cells.",
vbInformation, "No Duplicates"
End If
Set dic = Nothing
End If
End Sub

HTH

"mike b" wrote:

Hi

Looking for macro code to delete duplicates based on column B. First I
think the data needs to be sorted so the dups are under each other and then
delete the dups.
thanks for the help
--
Mike B

Jim,

I'm just looking for something simple based on column B and want to keep it
in the current sheet as well. Do you have anything simpler?

Thanks


"Jim Thomlinson" wrote:

Here is some code that I use to generate lists of unique items or lists of
duplicated items (the lists show up in their own new sheet). To run the code
select column B and then run GetUniqueItems. You should paste this code into
a module and reference that module to "Microsoft Scripting Runtime".

Option Explicit

Private Sub GetUniqueItems()
Dim cell As Range 'Current cell in range to check
Dim rngToSearch As Range 'Cells to be searched
Dim dic As Scripting.Dictionary 'Dictionary Object
Dim dicItem As Variant 'Items within dictionary object
Dim wks As Worksheet 'Worksheet to populate with
unique items
Dim rngPaste As Range 'Cells where unique items are
placed

'Create range to be searched
Set rngToSearch = Intersect(ActiveSheet.UsedRange, Selection)

'Confirm there is a relevant range selected
If Not rngToSearch Is Nothing Then
'Create dictionay object
Set dic = New Scripting.Dictionary

'Populate dictionary object with unique items (use key to define
unique)
For Each cell In rngToSearch 'Traverse selected range
If Not dic.Exists(cell.Value) Then 'Check the key
dic.Add cell.Value, cell.Value 'Add the item if unique
End If
Next

If Not dic Is Nothing Then 'Check for dictionary
Set wks = Worksheets.Add 'Create worksheet to populate
Set rngPaste = wks.Range("A1") 'Create range to populate
For Each dicItem In dic.Items 'Loop through dictionary
rngPaste.NumberFormat = "@" 'Format cell as text
rngPaste.Value = dicItem 'Add items to new sheet
Set rngPaste = rngPaste.Offset(1, 0) 'Increment paste range
Next dicItem
'Clean up objects
Set wks = Nothing
Set rngPaste = Nothing
Set dic = Nothing
End If
End If
End Sub

Private Sub GetDuplicateItems()
Dim cell As Range 'Current cell in range to check
Dim rngToSearch As Range 'Cells to be searched
Dim dic As Scripting.Dictionary 'Dictionary Object
Dim dicItem As Variant 'Items within dictionary object
Dim wks As Worksheet 'Worksheet to populate with
unique items
Dim rngPaste As Range 'Cells where unique items are
placed
Dim aryDuplicates() As String
Dim lngCounter As Long

'Create range to be searched
Set rngToSearch = Intersect(ActiveSheet.UsedRange, Selection)
lngCounter = 0

'Confirm there is a relevant range selected
If Not rngToSearch Is Nothing Then
'Create dictionay object
Set dic = New Scripting.Dictionary

'Populate dictionary object with unique items (use key to define
unique)
For Each cell In rngToSearch 'Traverse selected range
If Not dic.Exists(cell.Value) Then 'Check the key
dic.Add cell.Value, cell.Value 'Add the item if unique
Else
ReDim Preserve aryDuplicates(lngCounter)
aryDuplicates(lngCounter) = cell
lngCounter = lngCounter + 1
End If
Next

If lngCounter 0 Then 'Check for values
Set wks = Worksheets.Add 'Create worksheet to populate
Set rngPaste = wks.Range("A1") 'Create range to populate
For lngCounter = LBound(aryDuplicates) To UBound(aryDuplicates)
'Loop duplicates
rngPaste.NumberFormat = "@" 'Format cell as text
rngPaste.Value = aryDuplicates(lngCounter) 'Add items to
new sheet
Set rngPaste = rngPaste.Offset(1, 0) 'Increment paste range
Next lngCounter
'Clean up objects
Set wks = Nothing
Set rngPaste = Nothing
Else
MsgBox "There are no duplicate items in the selected cells.",
vbInformation, "No Duplicates"
End If
Set dic = Nothing
End If
End Sub

HTH

"mike b" wrote:

Hi

Looking for macro code to delete duplicates based on column B. First I
think the data needs to be sorted so the dups are under each other and then
delete the dups.
thanks for the help
--
Mike B

Let me look at doing something. You understand that there is no undo on a
macro so if we modify the current sheet and delete those duplicate lines that
there is no going back and the original source data is gone for good...
Additionally if for some reason the code crashes... again the original data
is gone for good... Just a warning...

"mike b" wrote:

Jim,

I'm just looking for something simple based on column B and want to keep it
in the current sheet as well. Do you have anything simpler?

Thanks


"Jim Thomlinson" wrote:

Here is some code that I use to generate lists of unique items or lists of
duplicated items (the lists show up in their own new sheet). To run the code
select column B and then run GetUniqueItems. You should paste this code into
a module and reference that module to "Microsoft Scripting Runtime".

Option Explicit

Private Sub GetUniqueItems()
Dim cell As Range 'Current cell in range to check
Dim rngToSearch As Range 'Cells to be searched
Dim dic As Scripting.Dictionary 'Dictionary Object
Dim dicItem As Variant 'Items within dictionary object
Dim wks As Worksheet 'Worksheet to populate with
unique items
Dim rngPaste As Range 'Cells where unique items are
placed

'Create range to be searched
Set rngToSearch = Intersect(ActiveSheet.UsedRange, Selection)

'Confirm there is a relevant range selected
If Not rngToSearch Is Nothing Then
'Create dictionay object
Set dic = New Scripting.Dictionary

'Populate dictionary object with unique items (use key to define
unique)
For Each cell In rngToSearch 'Traverse selected range
If Not dic.Exists(cell.Value) Then 'Check the key
dic.Add cell.Value, cell.Value 'Add the item if unique
End If
Next

If Not dic Is Nothing Then 'Check for dictionary
Set wks = Worksheets.Add 'Create worksheet to populate
Set rngPaste = wks.Range("A1") 'Create range to populate
For Each dicItem In dic.Items 'Loop through dictionary
rngPaste.NumberFormat = "@" 'Format cell as text
rngPaste.Value = dicItem 'Add items to new sheet
Set rngPaste = rngPaste.Offset(1, 0) 'Increment paste range
Next dicItem
'Clean up objects
Set wks = Nothing
Set rngPaste = Nothing
Set dic = Nothing
End If
End If
End Sub

Private Sub GetDuplicateItems()
Dim cell As Range 'Current cell in range to check
Dim rngToSearch As Range 'Cells to be searched
Dim dic As Scripting.Dictionary 'Dictionary Object
Dim dicItem As Variant 'Items within dictionary object
Dim wks As Worksheet 'Worksheet to populate with
unique items
Dim rngPaste As Range 'Cells where unique items are
placed
Dim aryDuplicates() As String
Dim lngCounter As Long

'Create range to be searched
Set rngToSearch = Intersect(ActiveSheet.UsedRange, Selection)
lngCounter = 0

'Confirm there is a relevant range selected
If Not rngToSearch Is Nothing Then
'Create dictionay object
Set dic = New Scripting.Dictionary

'Populate dictionary object with unique items (use key to define
unique)
For Each cell In rngToSearch 'Traverse selected range
If Not dic.Exists(cell.Value) Then 'Check the key
dic.Add cell.Value, cell.Value 'Add the item if unique
Else
ReDim Preserve aryDuplicates(lngCounter)
aryDuplicates(lngCounter) = cell
lngCounter = lngCounter + 1
End If
Next

If lngCounter 0 Then 'Check for values
Set wks = Worksheets.Add 'Create worksheet to populate
Set rngPaste = wks.Range("A1") 'Create range to populate
For lngCounter = LBound(aryDuplicates) To UBound(aryDuplicates)
'Loop duplicates
rngPaste.NumberFormat = "@" 'Format cell as text
rngPaste.Value = aryDuplicates(lngCounter) 'Add items to
new sheet
Set rngPaste = rngPaste.Offset(1, 0) 'Increment paste range
Next lngCounter
'Clean up objects
Set wks = Nothing
Set rngPaste = Nothing
Else
MsgBox "There are no duplicate items in the selected cells.",
vbInformation, "No Duplicates"
End If
Set dic = Nothing
End If
End Sub

HTH

"mike b" wrote:

Hi

Looking for macro code to delete duplicates based on column B. First I
think the data needs to be sorted so the dups are under each other and then
delete the dups.
thanks for the help
--
Mike B

Give this a try...

Public Sub SortAndDelete()
Dim wks As Worksheet
Dim rng As Range

Set wks = ActiveSheet
Set rng = wks.Cells

rng.Sort Key1:=wks.Range("B2"), Order1:=xlAscending, Header:=xlYes

Set rng = wks.Range("B65535").End(xlUp)
Do While rng.Row 1
Set rng = rng.Offset(-1, 0)
If rng.Offset(1, 0).Value = rng.Value Then rng.Offset(1,
0).EntireRow.Delete
Loop
Set wks = Nothing
Set rng = Nothing

End Sub

"mike b" wrote:

Jim,

I'm just looking for something simple based on column B and want to keep it
in the current sheet as well. Do you have anything simpler?

Thanks


"Jim Thomlinson" wrote:

Here is some code that I use to generate lists of unique items or lists of
duplicated items (the lists show up in their own new sheet). To run the code
select column B and then run GetUniqueItems. You should paste this code into
a module and reference that module to "Microsoft Scripting Runtime".

Option Explicit

Private Sub GetUniqueItems()
Dim cell As Range 'Current cell in range to check
Dim rngToSearch As Range 'Cells to be searched
Dim dic As Scripting.Dictionary 'Dictionary Object
Dim dicItem As Variant 'Items within dictionary object
Dim wks As Worksheet 'Worksheet to populate with
unique items
Dim rngPaste As Range 'Cells where unique items are
placed

'Create range to be searched
Set rngToSearch = Intersect(ActiveSheet.UsedRange, Selection)

'Confirm there is a relevant range selected
If Not rngToSearch Is Nothing Then
'Create dictionay object
Set dic = New Scripting.Dictionary

'Populate dictionary object with unique items (use key to define
unique)
For Each cell In rngToSearch 'Traverse selected range
If Not dic.Exists(cell.Value) Then 'Check the key
dic.Add cell.Value, cell.Value 'Add the item if unique
End If
Next

If Not dic Is Nothing Then 'Check for dictionary
Set wks = Worksheets.Add 'Create worksheet to populate
Set rngPaste = wks.Range("A1") 'Create range to populate
For Each dicItem In dic.Items 'Loop through dictionary
rngPaste.NumberFormat = "@" 'Format cell as text
rngPaste.Value = dicItem 'Add items to new sheet
Set rngPaste = rngPaste.Offset(1, 0) 'Increment paste range
Next dicItem
'Clean up objects
Set wks = Nothing
Set rngPaste = Nothing
Set dic = Nothing
End If
End If
End Sub

Private Sub GetDuplicateItems()
Dim cell As Range 'Current cell in range to check
Dim rngToSearch As Range 'Cells to be searched
Dim dic As Scripting.Dictionary 'Dictionary Object
Dim dicItem As Variant 'Items within dictionary object
Dim wks As Worksheet 'Worksheet to populate with
unique items
Dim rngPaste As Range 'Cells where unique items are
placed
Dim aryDuplicates() As String
Dim lngCounter As Long

'Create range to be searched
Set rngToSearch = Intersect(ActiveSheet.UsedRange, Selection)
lngCounter = 0

'Confirm there is a relevant range selected
If Not rngToSearch Is Nothing Then
'Create dictionay object
Set dic = New Scripting.Dictionary

'Populate dictionary object with unique items (use key to define
unique)
For Each cell In rngToSearch 'Traverse selected range
If Not dic.Exists(cell.Value) Then 'Check the key
dic.Add cell.Value, cell.Value 'Add the item if unique
Else
ReDim Preserve aryDuplicates(lngCounter)
aryDuplicates(lngCounter) = cell
lngCounter = lngCounter + 1
End If
Next

If lngCounter 0 Then 'Check for values
Set wks = Worksheets.Add 'Create worksheet to populate
Set rngPaste = wks.Range("A1") 'Create range to populate
For lngCounter = LBound(aryDuplicates) To UBound(aryDuplicates)
'Loop duplicates
rngPaste.NumberFormat = "@" 'Format cell as text
rngPaste.Value = aryDuplicates(lngCounter) 'Add items to
new sheet
Set rngPaste = rngPaste.Offset(1, 0) 'Increment paste range
Next lngCounter
'Clean up objects
Set wks = Nothing
Set rngPaste = Nothing
Else
MsgBox "There are no duplicate items in the selected cells.",
vbInformation, "No Duplicates"
End If
Set dic = Nothing
End If
End Sub

HTH

"mike b" wrote:

Hi

Looking for macro code to delete duplicates based on column B. First I
think the data needs to be sorted so the dups are under each other and then
delete the dups.
thanks for the help
--
Mike B

Code works, but I do not have a header row, what part and where do I need to
take that out?
Thanks

"Jim Thomlinson" wrote:

Give this a try...

Public Sub SortAndDelete()
Dim wks As Worksheet
Dim rng As Range

Set wks = ActiveSheet
Set rng = wks.Cells

rng.Sort Key1:=wks.Range("B2"), Order1:=xlAscending, Header:=xlYes

Set rng = wks.Range("B65535").End(xlUp)
Do While rng.Row 1
Set rng = rng.Offset(-1, 0)
If rng.Offset(1, 0).Value = rng.Value Then rng.Offset(1,
0).EntireRow.Delete
Loop
Set wks = Nothing
Set rng = Nothing

End Sub

"mike b" wrote:

Jim,

I'm just looking for something simple based on column B and want to keep it
in the current sheet as well. Do you have anything simpler?

Thanks


"Jim Thomlinson" wrote:

Here is some code that I use to generate lists of unique items or lists of
duplicated items (the lists show up in their own new sheet). To run the code
select column B and then run GetUniqueItems. You should paste this code into
a module and reference that module to "Microsoft Scripting Runtime".

Option Explicit

Private Sub GetUniqueItems()
Dim cell As Range 'Current cell in range to check
Dim rngToSearch As Range 'Cells to be searched
Dim dic As Scripting.Dictionary 'Dictionary Object
Dim dicItem As Variant 'Items within dictionary object
Dim wks As Worksheet 'Worksheet to populate with
unique items
Dim rngPaste As Range 'Cells where unique items are
placed

'Create range to be searched
Set rngToSearch = Intersect(ActiveSheet.UsedRange, Selection)

'Confirm there is a relevant range selected
If Not rngToSearch Is Nothing Then
'Create dictionay object
Set dic = New Scripting.Dictionary

'Populate dictionary object with unique items (use key to define
unique)
For Each cell In rngToSearch 'Traverse selected range
If Not dic.Exists(cell.Value) Then 'Check the key
dic.Add cell.Value, cell.Value 'Add the item if unique
End If
Next

If Not dic Is Nothing Then 'Check for dictionary
Set wks = Worksheets.Add 'Create worksheet to populate
Set rngPaste = wks.Range("A1") 'Create range to populate
For Each dicItem In dic.Items 'Loop through dictionary
rngPaste.NumberFormat = "@" 'Format cell as text
rngPaste.Value = dicItem 'Add items to new sheet
Set rngPaste = rngPaste.Offset(1, 0) 'Increment paste range
Next dicItem
'Clean up objects
Set wks = Nothing
Set rngPaste = Nothing
Set dic = Nothing
End If
End If
End Sub

Private Sub GetDuplicateItems()
Dim cell As Range 'Current cell in range to check
Dim rngToSearch As Range 'Cells to be searched
Dim dic As Scripting.Dictionary 'Dictionary Object
Dim dicItem As Variant 'Items within dictionary object
Dim wks As Worksheet 'Worksheet to populate with
unique items
Dim rngPaste As Range 'Cells where unique items are
placed
Dim aryDuplicates() As String
Dim lngCounter As Long

'Create range to be searched
Set rngToSearch = Intersect(ActiveSheet.UsedRange, Selection)
lngCounter = 0

'Confirm there is a relevant range selected
If Not rngToSearch Is Nothing Then
'Create dictionay object
Set dic = New Scripting.Dictionary

'Populate dictionary object with unique items (use key to define
unique)
For Each cell In rngToSearch 'Traverse selected range
If Not dic.Exists(cell.Value) Then 'Check the key
dic.Add cell.Value, cell.Value 'Add the item if unique
Else
ReDim Preserve aryDuplicates(lngCounter)
aryDuplicates(lngCounter) = cell
lngCounter = lngCounter + 1
End If
Next

If lngCounter 0 Then 'Check for values
Set wks = Worksheets.Add 'Create worksheet to populate
Set rngPaste = wks.Range("A1") 'Create range to populate
For lngCounter = LBound(aryDuplicates) To UBound(aryDuplicates)
'Loop duplicates
rngPaste.NumberFormat = "@" 'Format cell as text
rngPaste.Value = aryDuplicates(lngCounter) 'Add items to
new sheet
Set rngPaste = rngPaste.Offset(1, 0) 'Increment paste range
Next lngCounter
'Clean up objects
Set wks = Nothing
Set rngPaste = Nothing
Else
MsgBox "There are no duplicate items in the selected cells.",
vbInformation, "No Duplicates"
End If
Set dic = Nothing
End If
End Sub

HTH

"mike b" wrote:

Hi

Looking for macro code to delete duplicates based on column B. First I
think the data needs to be sorted so the dups are under each other and then
delete the dups.
thanks for the help
--
Mike B

Change
Header:=xlYes

to

Header:=xlNo

"mike b" wrote:

Code works, but I do not have a header row, what part and where do I need to
take that out?
Thanks

"Jim Thomlinson" wrote:

Give this a try...

Public Sub SortAndDelete()
Dim wks As Worksheet
Dim rng As Range

Set wks = ActiveSheet
Set rng = wks.Cells

rng.Sort Key1:=wks.Range("B2"), Order1:=xlAscending, Header:=xlYes

Set rng = wks.Range("B65535").End(xlUp)
Do While rng.Row 1
Set rng = rng.Offset(-1, 0)
If rng.Offset(1, 0).Value = rng.Value Then rng.Offset(1,
0).EntireRow.Delete
Loop
Set wks = Nothing
Set rng = Nothing

End Sub

"mike b" wrote:

Jim,

I'm just looking for something simple based on column B and want to keep it
in the current sheet as well. Do you have anything simpler?

Thanks


"Jim Thomlinson" wrote:

Here is some code that I use to generate lists of unique items or lists of
duplicated items (the lists show up in their own new sheet). To run the code
select column B and then run GetUniqueItems. You should paste this code into
a module and reference that module to "Microsoft Scripting Runtime".

Option Explicit

Private Sub GetUniqueItems()
Dim cell As Range 'Current cell in range to check
Dim rngToSearch As Range 'Cells to be searched
Dim dic As Scripting.Dictionary 'Dictionary Object
Dim dicItem As Variant 'Items within dictionary object
Dim wks As Worksheet 'Worksheet to populate with
unique items
Dim rngPaste As Range 'Cells where unique items are
placed

'Create range to be searched
Set rngToSearch = Intersect(ActiveSheet.UsedRange, Selection)

'Confirm there is a relevant range selected
If Not rngToSearch Is Nothing Then
'Create dictionay object
Set dic = New Scripting.Dictionary

'Populate dictionary object with unique items (use key to define
unique)
For Each cell In rngToSearch 'Traverse selected range
If Not dic.Exists(cell.Value) Then 'Check the key
dic.Add cell.Value, cell.Value 'Add the item if unique
End If
Next

If Not dic Is Nothing Then 'Check for dictionary
Set wks = Worksheets.Add 'Create worksheet to populate
Set rngPaste = wks.Range("A1") 'Create range to populate
For Each dicItem In dic.Items 'Loop through dictionary
rngPaste.NumberFormat = "@" 'Format cell as text
rngPaste.Value = dicItem 'Add items to new sheet
Set rngPaste = rngPaste.Offset(1, 0) 'Increment paste range
Next dicItem
'Clean up objects
Set wks = Nothing
Set rngPaste = Nothing
Set dic = Nothing
End If
End If
End Sub

Private Sub GetDuplicateItems()
Dim cell As Range 'Current cell in range to check
Dim rngToSearch As Range 'Cells to be searched
Dim dic As Scripting.Dictionary 'Dictionary Object
Dim dicItem As Variant 'Items within dictionary object
Dim wks As Worksheet 'Worksheet to populate with
unique items
Dim rngPaste As Range 'Cells where unique items are
placed
Dim aryDuplicates() As String
Dim lngCounter As Long

'Create range to be searched
Set rngToSearch = Intersect(ActiveSheet.UsedRange, Selection)
lngCounter = 0

'Confirm there is a relevant range selected
If Not rngToSearch Is Nothing Then
'Create dictionay object
Set dic = New Scripting.Dictionary

'Populate dictionary object with unique items (use key to define
unique)
For Each cell In rngToSearch 'Traverse selected range
If Not dic.Exists(cell.Value) Then 'Check the key
dic.Add cell.Value, cell.Value 'Add the item if unique
Else
ReDim Preserve aryDuplicates(lngCounter)
aryDuplicates(lngCounter) = cell
lngCounter = lngCounter + 1
End If
Next

If lngCounter 0 Then 'Check for values
Set wks = Worksheets.Add 'Create worksheet to populate
Set rngPaste = wks.Range("A1") 'Create range to populate
For lngCounter = LBound(aryDuplicates) To UBound(aryDuplicates)
'Loop duplicates
rngPaste.NumberFormat = "@" 'Format cell as text
rngPaste.Value = aryDuplicates(lngCounter) 'Add items to
new sheet
Set rngPaste = rngPaste.Offset(1, 0) 'Increment paste range
Next lngCounter
'Clean up objects
Set wks = Nothing
Set rngPaste = Nothing
Else
MsgBox "There are no duplicate items in the selected cells.",
vbInformation, "No Duplicates"
End If
Set dic = Nothing
End If
End Sub

HTH

"mike b" wrote:

Hi

Looking for macro code to delete duplicates based on column B. First I
think the data needs to be sorted so the dups are under each other and then
delete the dups.
thanks for the help
--
Mike B

Thank you so much, it worked.

One last question. Can I break this macro up to just sort the data. and
then run another one to delte next? I want to be able to see the dups before
deleting.

Thanks again
Mike

"Jim Thomlinson" wrote:

Change
Header:=xlYes

to

Header:=xlNo

"mike b" wrote:

Code works, but I do not have a header row, what part and where do I need to
take that out?
Thanks

"Jim Thomlinson" wrote:

Give this a try...

Public Sub SortAndDelete()
Dim wks As Worksheet
Dim rng As Range

Set wks = ActiveSheet
Set rng = wks.Cells

rng.Sort Key1:=wks.Range("B2"), Order1:=xlAscending, Header:=xlYes

Set rng = wks.Range("B65535").End(xlUp)
Do While rng.Row 1
Set rng = rng.Offset(-1, 0)
If rng.Offset(1, 0).Value = rng.Value Then rng.Offset(1,
0).EntireRow.Delete
Loop
Set wks = Nothing
Set rng = Nothing

End Sub

"mike b" wrote:

Jim,

I'm just looking for something simple based on column B and want to keep it
in the current sheet as well. Do you have anything simpler?

Thanks


"Jim Thomlinson" wrote:

Here is some code that I use to generate lists of unique items or lists of
duplicated items (the lists show up in their own new sheet). To run the code
select column B and then run GetUniqueItems. You should paste this code into
a module and reference that module to "Microsoft Scripting Runtime".

Option Explicit

Private Sub GetUniqueItems()
Dim cell As Range 'Current cell in range to check
Dim rngToSearch As Range 'Cells to be searched
Dim dic As Scripting.Dictionary 'Dictionary Object
Dim dicItem As Variant 'Items within dictionary object
Dim wks As Worksheet 'Worksheet to populate with
unique items
Dim rngPaste As Range 'Cells where unique items are
placed

'Create range to be searched
Set rngToSearch = Intersect(ActiveSheet.UsedRange, Selection)

'Confirm there is a relevant range selected
If Not rngToSearch Is Nothing Then
'Create dictionay object
Set dic = New Scripting.Dictionary

'Populate dictionary object with unique items (use key to define
unique)
For Each cell In rngToSearch 'Traverse selected range
If Not dic.Exists(cell.Value) Then 'Check the key
dic.Add cell.Value, cell.Value 'Add the item if unique
End If
Next

If Not dic Is Nothing Then 'Check for dictionary
Set wks = Worksheets.Add 'Create worksheet to populate
Set rngPaste = wks.Range("A1") 'Create range to populate
For Each dicItem In dic.Items 'Loop through dictionary
rngPaste.NumberFormat = "@" 'Format cell as text
rngPaste.Value = dicItem 'Add items to new sheet
Set rngPaste = rngPaste.Offset(1, 0) 'Increment paste range
Next dicItem
'Clean up objects
Set wks = Nothing
Set rngPaste = Nothing
Set dic = Nothing
End If
End If
End Sub

Private Sub GetDuplicateItems()
Dim cell As Range 'Current cell in range to check
Dim rngToSearch As Range 'Cells to be searched
Dim dic As Scripting.Dictionary 'Dictionary Object
Dim dicItem As Variant 'Items within dictionary object
Dim wks As Worksheet 'Worksheet to populate with
unique items
Dim rngPaste As Range 'Cells where unique items are
placed
Dim aryDuplicates() As String
Dim lngCounter As Long

'Create range to be searched
Set rngToSearch = Intersect(ActiveSheet.UsedRange, Selection)
lngCounter = 0

'Confirm there is a relevant range selected
If Not rngToSearch Is Nothing Then
'Create dictionay object
Set dic = New Scripting.Dictionary

'Populate dictionary object with unique items (use key to define
unique)
For Each cell In rngToSearch 'Traverse selected range
If Not dic.Exists(cell.Value) Then 'Check the key
dic.Add cell.Value, cell.Value 'Add the item if unique
Else
ReDim Preserve aryDuplicates(lngCounter)
aryDuplicates(lngCounter) = cell
lngCounter = lngCounter + 1
End If
Next

If lngCounter 0 Then 'Check for values
Set wks = Worksheets.Add 'Create worksheet to populate
Set rngPaste = wks.Range("A1") 'Create range to populate
For lngCounter = LBound(aryDuplicates) To UBound(aryDuplicates)
'Loop duplicates
rngPaste.NumberFormat = "@" 'Format cell as text
rngPaste.Value = aryDuplicates(lngCounter) 'Add items to
new sheet
Set rngPaste = rngPaste.Offset(1, 0) 'Increment paste range
Next lngCounter
'Clean up objects
Set wks = Nothing
Set rngPaste = Nothing
Else
MsgBox "There are no duplicate items in the selected cells.",
vbInformation, "No Duplicates"
End If
Set dic = Nothing
End If
End Sub

HTH

"mike b" wrote:

Hi

Looking for macro code to delete duplicates based on column B. First I
think the data needs to be sorted so the dups are under each other and then
delete the dups.
thanks for the help
--
Mike B

Public Sub DeleteStuff()
Dim wks As Worksheet
Dim rng As Range

Set wks = ActiveSheet
Set rng = wks.Cells

Set rng = wks.Range("B65535").End(xlUp)
Do While rng.Row 1
Set rng = rng.Offset(-1, 0)
If rng.Offset(1, 0).Value = rng.Value Then rng.Offset(1,
0).EntireRow.Delete
Loop
Set wks = Nothing
Set rng = Nothing

End Sub

Public Sub SortStuff()
Dim wks As Worksheet
Dim rng As Range

Set wks = ActiveSheet
Set rng = wks.Cells

rng.Sort Key1:=wks.Range("B2"), Order1:=xlAscending, Header:=xlNo

Set wks = Nothing
Set rng = Nothing
End Sub


"mike b" wrote:

Thank you so much, it worked.

One last question. Can I break this macro up to just sort the data. and
then run another one to delte next? I want to be able to see the dups before
deleting.

Thanks again
Mike

"Jim Thomlinson" wrote:

Change
Header:=xlYes

to

Header:=xlNo

"mike b" wrote:

Code works, but I do not have a header row, what part and where do I need to
take that out?
Thanks

"Jim Thomlinson" wrote:

Give this a try...

Public Sub SortAndDelete()
Dim wks As Worksheet
Dim rng As Range

Set wks = ActiveSheet
Set rng = wks.Cells

rng.Sort Key1:=wks.Range("B2"), Order1:=xlAscending, Header:=xlYes

Set rng = wks.Range("B65535").End(xlUp)
Do While rng.Row 1
Set rng = rng.Offset(-1, 0)
If rng.Offset(1, 0).Value = rng.Value Then rng.Offset(1,
0).EntireRow.Delete
Loop
Set wks = Nothing
Set rng = Nothing

End Sub

"mike b" wrote:

Jim,

I'm just looking for something simple based on column B and want to keep it
in the current sheet as well. Do you have anything simpler?

Thanks


"Jim Thomlinson" wrote:

Here is some code that I use to generate lists of unique items or lists of
duplicated items (the lists show up in their own new sheet). To run the code
select column B and then run GetUniqueItems. You should paste this code into
a module and reference that module to "Microsoft Scripting Runtime".

Option Explicit

Private Sub GetUniqueItems()
Dim cell As Range 'Current cell in range to check
Dim rngToSearch As Range 'Cells to be searched
Dim dic As Scripting.Dictionary 'Dictionary Object
Dim dicItem As Variant 'Items within dictionary object
Dim wks As Worksheet 'Worksheet to populate with
unique items
Dim rngPaste As Range 'Cells where unique items are
placed

'Create range to be searched
Set rngToSearch = Intersect(ActiveSheet.UsedRange, Selection)

'Confirm there is a relevant range selected
If Not rngToSearch Is Nothing Then
'Create dictionay object
Set dic = New Scripting.Dictionary

'Populate dictionary object with unique items (use key to define
unique)
For Each cell In rngToSearch 'Traverse selected range
If Not dic.Exists(cell.Value) Then 'Check the key
dic.Add cell.Value, cell.Value 'Add the item if unique
End If
Next

If Not dic Is Nothing Then 'Check for dictionary
Set wks = Worksheets.Add 'Create worksheet to populate
Set rngPaste = wks.Range("A1") 'Create range to populate
For Each dicItem In dic.Items 'Loop through dictionary
rngPaste.NumberFormat = "@" 'Format cell as text
rngPaste.Value = dicItem 'Add items to new sheet
Set rngPaste = rngPaste.Offset(1, 0) 'Increment paste range
Next dicItem
'Clean up objects
Set wks = Nothing
Set rngPaste = Nothing
Set dic = Nothing
End If
End If
End Sub

Private Sub GetDuplicateItems()
Dim cell As Range 'Current cell in range to check
Dim rngToSearch As Range 'Cells to be searched
Dim dic As Scripting.Dictionary 'Dictionary Object
Dim dicItem As Variant 'Items within dictionary object
Dim wks As Worksheet 'Worksheet to populate with
unique items
Dim rngPaste As Range 'Cells where unique items are
placed
Dim aryDuplicates() As String
Dim lngCounter As Long

'Create range to be searched
Set rngToSearch = Intersect(ActiveSheet.UsedRange, Selection)
lngCounter = 0

'Confirm there is a relevant range selected
If Not rngToSearch Is Nothing Then
'Create dictionay object
Set dic = New Scripting.Dictionary

'Populate dictionary object with unique items (use key to define
unique)
For Each cell In rngToSearch 'Traverse selected range
If Not dic.Exists(cell.Value) Then 'Check the key
dic.Add cell.Value, cell.Value 'Add the item if unique
Else
ReDim Preserve aryDuplicates(lngCounter)
aryDuplicates(lngCounter) = cell
lngCounter = lngCounter + 1
End If
Next

If lngCounter 0 Then 'Check for values
Set wks = Worksheets.Add 'Create worksheet to populate
Set rngPaste = wks.Range("A1") 'Create range to populate
For lngCounter = LBound(aryDuplicates) To UBound(aryDuplicates)
'Loop duplicates
rngPaste.NumberFormat = "@" 'Format cell as text
rngPaste.Value = aryDuplicates(lngCounter) 'Add items to
new sheet
Set rngPaste = rngPaste.Offset(1, 0) 'Increment paste range
Next lngCounter
'Clean up objects
Set wks = Nothing
Set rngPaste = Nothing
Else
MsgBox "There are no duplicate items in the selected cells.",
vbInformation, "No Duplicates"
End If
Set dic = Nothing
End If
End Sub

HTH

"mike b" wrote:

Hi

Looking for macro code to delete duplicates based on column B. First I
think the data needs to be sorted so the dups are under each other and then
delete the dups.
thanks for the help
--
Mike B