I would like to create a macro that would work only on coulomb A. Coulomb A
can contain duplicate names(such as music artists). I would like to clear
the contents of all the duplicate names and then set the original name in
BOLD.
Thanks

Hi Stanley,

Make sure you backup your workbook before running this code because it is
deleting rows and you need to confirm that it is doing what you want it to.
(I have assumed that you want to delete the entire row so if this is not
correct then please get back to me.)

The code inserts a temporary column B to mark the rows to be deleted and
then runs the deletions later and removes the temporary column B.

The code runs on the active sheet so you also need to ensure that the sheet
to be processed is the active sheet before running the code.

Sub RemoveDuplicates()

Dim rngToTest As Range
Dim rngTofind As Range
Dim cel As Range
Dim firstAddress As String
Dim i As Long
Dim rngSave As Range

With ActiveSheet
Set rngToTest = Range(.Cells(2, "A"), _
Cells(.Rows.Count, "A").End(xlUp))
End With

'Insert a temporary column to hold delete flag
Columns("B:B").Insert Shift:=xlToRight

Application.ScreenUpdating = False

For Each rngTofind In rngToTest

'Test if value already searched
If rngTofind.Offset(0, 1) < "Delete" Then
Set cel = Columns("A:A").Find(What:=rngTofind.Value, _
After:=Cells(Rows.Count, "A"), _
LookIn:=xlFormulas, _
LookAt:=xlWhole, _
SearchOrder:=xlByRows, _
SearchDirection:=xlNext, _
MatchCase:=False, _
SearchFormat:=False)

Set rngSave = Nothing
If Not cel Is Nothing Then 'Found
firstAddress = cel.Address
Set rngSave = cel 'Save the location
Set cel = rngToTest.FindNext(cel)
Do While Not cel Is Nothing And _
cel.Address < firstAddress
cel.Offset(0, 1) = "Delete"
rngSave.Font.Bold = True 'Bold original find
Set cel = rngToTest.FindNext(cel)
Loop
End If
End If
Next rngTofind

With rngToTest
'Work backwards when deleting rows
For i = .Rows.Count To 1 Step -1
If .Cells(i, 1).Offset(0, 1) = "Delete" Then
.Cells(i, 1).EntireRow.Delete
End If
Next i
End With

'Delete the temporary column
Columns("B:B").Delete
Application.ScreenUpdating = True

End Sub

--
Regards,

OssieMac


"Stanley Braverman" wrote:

I would like to create a macro that would work only on coulomb A. Coulomb A
can contain duplicate names(such as music artists). I would like to clear
the contents of all the duplicate names and then set the original name in
BOLD.
Thanks

(I have assumed that you want to delete the entire row so if this is not
Correct then please get back to me.)

Actually no. I have 3 additional coulombs and would like to keep the
contents intact.
I would need the deleted cells just to be left clear. Other then that the
code runs well without errors.
Thanks


(I have assumed that you want to delete the entire row so if this is not
correct then please get back to me.)

The code inserts a temporary column B to mark the rows to be deleted and
then runs the deletions later and removes the temporary column B.

The code runs on the active sheet so you also need to ensure that the
sheet
to be processed is the active sheet before running the code.

Sub RemoveDuplicates()

Dim rngToTest As Range
Dim rngTofind As Range
Dim cel As Range
Dim firstAddress As String
Dim i As Long
Dim rngSave As Range

With ActiveSheet
Set rngToTest = Range(.Cells(2, "A"), _
Cells(.Rows.Count, "A").End(xlUp))
End With

'Insert a temporary column to hold delete flag
Columns("B:B").Insert Shift:=xlToRight

Application.ScreenUpdating = False

For Each rngTofind In rngToTest

'Test if value already searched
If rngTofind.Offset(0, 1) < "Delete" Then
Set cel = Columns("A:A").Find(What:=rngTofind.Value, _
After:=Cells(Rows.Count, "A"), _
LookIn:=xlFormulas, _
LookAt:=xlWhole, _
SearchOrder:=xlByRows, _
SearchDirection:=xlNext, _
MatchCase:=False, _
SearchFormat:=False)

Set rngSave = Nothing
If Not cel Is Nothing Then 'Found
firstAddress = cel.Address
Set rngSave = cel 'Save the location
Set cel = rngToTest.FindNext(cel)
Do While Not cel Is Nothing And _
cel.Address < firstAddress
cel.Offset(0, 1) = "Delete"
rngSave.Font.Bold = True 'Bold original find
Set cel = rngToTest.FindNext(cel)
Loop
End If
End If
Next rngTofind

With rngToTest
'Work backwards when deleting rows
For i = .Rows.Count To 1 Step -1
If .Cells(i, 1).Offset(0, 1) = "Delete" Then
.Cells(i, 1).EntireRow.Delete
End If
Next i
End With

'Delete the temporary column
Columns("B:B").Delete
Application.ScreenUpdating = True

End Sub

--
Regards,

OssieMac


"Stanley Braverman" wrote:

I would like to create a macro that would work only on coulomb A. Coulomb
A
can contain duplicate names(such as music artists). I would like to clear
the contents of all the duplicate names and then set the original name in
BOLD.
Thanks

OK Stanley done. It just clears the cells now instead of deleting the rows.
Have also modified a couple of other bits that makes the code more generic
therefore replace all of the code.

Sub RemoveDuplicates()

Dim rngToTest As Range
Dim rngTofind As Range
Dim cel As Range
Dim firstAddress As String
Dim i As Long
Dim rngSave As Range

With ActiveSheet
Set rngToTest = Range(.Cells(2, "A"), _
.Cells(.Rows.Count, "A").End(xlUp))

'Insert a temporary column to hold delete flag
.Columns("B:B").Insert Shift:=xlToRight

End With

Application.ScreenUpdating = False

For Each rngTofind In rngToTest

'Test if value already searched
With rngToTest
If rngTofind.Offset(0, 1) < "Delete" Then
Set cel = .Columns("A:A").Find(What:=rngTofind.Value, _
After:=.Cells(.Rows.Count, "A"), _
LookIn:=xlFormulas, _
LookAt:=xlWhole, _
SearchOrder:=xlByRows, _
SearchDirection:=xlNext, _
MatchCase:=False, _
SearchFormat:=False)

Set rngSave = Nothing
If Not cel Is Nothing Then 'Found
firstAddress = cel.Address
Set rngSave = cel 'Save the location
Set cel = .FindNext(cel)
Do While Not cel Is Nothing And _
cel.Address < firstAddress
cel.Offset(0, 1) = "Delete"
rngSave.Font.Bold = True 'Bold original find
Set cel = .FindNext(cel)
Loop
End If
End If
End With
Next rngTofind

With rngToTest
'Work backwards when deleting rows
For i = .Rows.Count To 1 Step -1
If .Cells(i, 1).Offset(0, 1) = "Delete" Then
.Cells(i, 1).Clear
End If
Next i
End With

'Delete the temporary column
With ActiveSheet
.Columns("B:B").Delete
End With

Application.ScreenUpdating = True

End Sub


--
Regards,

OssieMac

Thanks OssieMac,
This works great.
Regards, Stan
"OssieMac" wrote in message
...
OK Stanley done. It just clears the cells now instead of deleting the
rows.
Have also modified a couple of other bits that makes the code more generic
therefore replace all of the code.

Sub RemoveDuplicates()

Dim rngToTest As Range
Dim rngTofind As Range
Dim cel As Range
Dim firstAddress As String
Dim i As Long
Dim rngSave As Range

With ActiveSheet
Set rngToTest = Range(.Cells(2, "A"), _
.Cells(.Rows.Count, "A").End(xlUp))

'Insert a temporary column to hold delete flag
.Columns("B:B").Insert Shift:=xlToRight

End With

Application.ScreenUpdating = False

For Each rngTofind In rngToTest

'Test if value already searched
With rngToTest
If rngTofind.Offset(0, 1) < "Delete" Then
Set cel = .Columns("A:A").Find(What:=rngTofind.Value, _
After:=.Cells(.Rows.Count, "A"), _
LookIn:=xlFormulas, _
LookAt:=xlWhole, _
SearchOrder:=xlByRows, _
SearchDirection:=xlNext, _
MatchCase:=False, _
SearchFormat:=False)

Set rngSave = Nothing
If Not cel Is Nothing Then 'Found
firstAddress = cel.Address
Set rngSave = cel 'Save the location
Set cel = .FindNext(cel)
Do While Not cel Is Nothing And _
cel.Address < firstAddress
cel.Offset(0, 1) = "Delete"
rngSave.Font.Bold = True 'Bold original find
Set cel = .FindNext(cel)
Loop
End If
End If
End With
Next rngTofind

With rngToTest
'Work backwards when deleting rows
For i = .Rows.Count To 1 Step -1
If .Cells(i, 1).Offset(0, 1) = "Delete" Then
.Cells(i, 1).Clear
End If
Next i
End With

'Delete the temporary column
With ActiveSheet
.Columns("B:B").Delete
End With

Application.ScreenUpdating = True

End Sub


--
Regards,

OssieMac