ExcelBanter

ExcelBanter (https://www.excelbanter.com/)
-   Excel Programming (https://www.excelbanter.com/excel-programming/)
-   -   Combining Macros into One Command (https://www.excelbanter.com/excel-programming/328696-combining-macros-into-one-command.html)

Sharon
Combining Macros into One Command
 
Hello,

I have four macros that I would like to consolidate into two. The first two
that should go together are the Sub Sort and Sub FindAndReplace. The second
two that I would like to be one command are HighlightFcstDups and
HighlightObsDups.

Can someone show me how to consolidate?

Here's the code:

'I would like these two macros to be consolidated into one macro:

Public Sub Sort()
Application.ScreenUpdating = False
ActiveSheet.Columns("A:Q").Select
Selection.Sort Key1:=Range("A1"), Order1:=xlAscending, Key2:=Range("B1") _
, Order2:=xlAscending, Key3:=Range("C1"), Order3:=xlAscending,
Header:= _
xlNo, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal, DataOption2:=xlSortNormal, DataOption3:= _
xlSortNormal
ActiveWindow.SmallScroll ToRight:=18
ActiveSheet.Columns("S:AI").Select
Selection.Sort Key1:=Range("S1"), Order1:=xlAscending, Key2:=Range("T1") _
, Order2:=xlAscending, Key3:=Range("U1"), Order3:=xlAscending,
Header:= _
xlGuess, OrderCustom:=1, MatchCase:=False,
Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal, DataOption2:=xlSortNormal, DataOption3:= _
xlSortNormal
Application.ScreenUpdating = True
Range("a1").Select
End Sub


Public Sub FindAndReplace()
Application.ScreenUpdating = False
Dim oColors As Range
With Worksheets("1_Import")
Set oColors = Union(.Range("B1:Q400"), Range("T1:AI400"))

oColors.Replace What:="green", Replacement:="G", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False
oColors.Replace What:="yellow", Replacement:="Y", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False
oColors.Replace What:="red", Replacement:="R", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False
oColors.Replace What:="no", Replacement:="NA", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False
Application.ScreenUpdating = True
End With
End Sub
----------------------------------------------------------------------

'These two macros I'd also like consolidated into one macro:

Sub HighlightFcstDups()

'Start at the currently selected cell
Range("a1").Select
x = ActiveCell.Row
y = x + 1

'Outside loop
Do While Cells(x, 1).Value < ""
'Inside loop
Do While Cells(y, 1).Value < ""
'Test for duplication:
'If the values of the third column (C) and the fifth column (E)
match in two rows (this part of the code I edited)
'delete the second row of the pair, otherwise go to the next row
until the end
If (Cells(x, 1).Value = Cells(y, 1).Value) Then

'FOR DUPLICATE DELETION: Uncommment the following line by
removing the apostrophe
'Cells(y, 3).EntireRow.Delete

'Shade the entire row green if it's a duplicate
'FOR DUPLICATE DELETION: Make the following line a comment
by adding an apostrophe
Cells(y, 1).EntireRow.Interior.ColorIndex = 4
Else

'FOR DUPLICATE DELETION: Uncomment the following line by
removing the apostrophe
'y = y + 1
End If

'FOR DUPLICATE DELETION: Make the following line a comment by
adding an apostrophe
y = y + 1
Loop
'increase the value of x by 1 to move the loop starting point to the
next row
x = x + 1
'reset y so it starts at the next row
y = x + 1
Loop

End Sub

Sub HighlightObsDups()

'Start at the currently selected cell
Range("S1").Select
x = ActiveCell.Row
y = x + 1

'Outside loop
Do While Cells(x, 19).Value < ""
'Inside loop
Do While Cells(y, 19).Value < ""
'Test for duplication:
'If the values of the third column (C) and the fifth column (E)
match in two rows (this part of the code I edited)
'delete the second row of the pair, otherwise go to the next row
until the end
If (Cells(x, 19).Value = Cells(y, 19).Value) Then

'FOR DUPLICATE DELETION: Uncommment the following line by
removing the apostrophe
'Cells(y, 3).EntireRow.Delete

'Shade the entire row green if it's a duplicate
'FOR DUPLICATE DELETION: Make the following line a comment
by adding an apostrophe
Cells(y, 19).EntireRow.Interior.ColorIndex = 4
Else

'FOR DUPLICATE DELETION: Uncomment the following line by
removing the apostrophe
'y = y + 1
End If

'FOR DUPLICATE DELETION: Make the following line a comment by
adding an apostrophe
y = y + 1
Loop
'increase the value of x by 1 to move the loop starting point to the
next row
x = x + 1
'reset y so it starts at the next row
y = x + 1
Loop

End Sub
----------------------------------------------------------------------------

Thanks for your help,

Sharon

Vasant Nanavati
Combining Macros into One Command
 
Just copy the text of the FindAndReplace sub (except fot he Sub ... End Sub
part) and past it into the Sort sub at the end, before the End Sub line.
Then delete the FindAndReplace sub.

Repeat for the other 2 subs.

--

Vasant

"Sharon" wrote in message
...
Hello,

I have four macros that I would like to consolidate into two. The first
two
that should go together are the Sub Sort and Sub FindAndReplace. The
second
two that I would like to be one command are HighlightFcstDups and
HighlightObsDups.

Can someone show me how to consolidate?

Here's the code:

'I would like these two macros to be consolidated into one macro:

Public Sub Sort()
Application.ScreenUpdating = False
ActiveSheet.Columns("A:Q").Select
Selection.Sort Key1:=Range("A1"), Order1:=xlAscending,
Key2:=Range("B1") _
, Order2:=xlAscending, Key3:=Range("C1"), Order3:=xlAscending,
Header:= _
xlNo, OrderCustom:=1, MatchCase:=False,
Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal, DataOption2:=xlSortNormal,
DataOption3:= _
xlSortNormal
ActiveWindow.SmallScroll ToRight:=18
ActiveSheet.Columns("S:AI").Select
Selection.Sort Key1:=Range("S1"), Order1:=xlAscending,
Key2:=Range("T1") _
, Order2:=xlAscending, Key3:=Range("U1"), Order3:=xlAscending,
Header:= _
xlGuess, OrderCustom:=1, MatchCase:=False,
Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal, DataOption2:=xlSortNormal,
DataOption3:= _
xlSortNormal
Application.ScreenUpdating = True
Range("a1").Select
End Sub


Public Sub FindAndReplace()
Application.ScreenUpdating = False
Dim oColors As Range
With Worksheets("1_Import")
Set oColors = Union(.Range("B1:Q400"), Range("T1:AI400"))

oColors.Replace What:="green", Replacement:="G", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False
oColors.Replace What:="yellow", Replacement:="Y", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False
oColors.Replace What:="red", Replacement:="R", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False
oColors.Replace What:="no", Replacement:="NA", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False
Application.ScreenUpdating = True
End With
End Sub
----------------------------------------------------------------------

'These two macros I'd also like consolidated into one macro:

Sub HighlightFcstDups()

'Start at the currently selected cell
Range("a1").Select
x = ActiveCell.Row
y = x + 1

'Outside loop
Do While Cells(x, 1).Value < ""
'Inside loop
Do While Cells(y, 1).Value < ""
'Test for duplication:
'If the values of the third column (C) and the fifth column
(E)
match in two rows (this part of the code I edited)
'delete the second row of the pair, otherwise go to the next
row
until the end
If (Cells(x, 1).Value = Cells(y, 1).Value) Then

'FOR DUPLICATE DELETION: Uncommment the following line by
removing the apostrophe
'Cells(y, 3).EntireRow.Delete

'Shade the entire row green if it's a duplicate
'FOR DUPLICATE DELETION: Make the following line a comment
by adding an apostrophe
Cells(y, 1).EntireRow.Interior.ColorIndex = 4
Else

'FOR DUPLICATE DELETION: Uncomment the following line by
removing the apostrophe
'y = y + 1
End If

'FOR DUPLICATE DELETION: Make the following line a comment by
adding an apostrophe
y = y + 1
Loop
'increase the value of x by 1 to move the loop starting point to
the
next row
x = x + 1
'reset y so it starts at the next row
y = x + 1
Loop

End Sub

Sub HighlightObsDups()

'Start at the currently selected cell
Range("S1").Select
x = ActiveCell.Row
y = x + 1

'Outside loop
Do While Cells(x, 19).Value < ""
'Inside loop
Do While Cells(y, 19).Value < ""
'Test for duplication:
'If the values of the third column (C) and the fifth column
(E)
match in two rows (this part of the code I edited)
'delete the second row of the pair, otherwise go to the next
row
until the end
If (Cells(x, 19).Value = Cells(y, 19).Value) Then

'FOR DUPLICATE DELETION: Uncommment the following line by
removing the apostrophe
'Cells(y, 3).EntireRow.Delete

'Shade the entire row green if it's a duplicate
'FOR DUPLICATE DELETION: Make the following line a comment
by adding an apostrophe
Cells(y, 19).EntireRow.Interior.ColorIndex = 4
Else

'FOR DUPLICATE DELETION: Uncomment the following line by
removing the apostrophe
'y = y + 1
End If

'FOR DUPLICATE DELETION: Make the following line a comment by
adding an apostrophe
y = y + 1
Loop
'increase the value of x by 1 to move the loop starting point to
the
next row
x = x + 1
'reset y so it starts at the next row
y = x + 1
Loop

End Sub
--------------------------------------------------------------------------
--

Thanks for your help,

Sharon

Sharon
Combining Macros into One Command
 
I also forgot to ask:

On the Highlight Duplicates macros, it highlights the entire row [ie:
Cells(y, 1).EntireRow.Interior.ColorIndex =4] I would like to change the
property EntireRow to just be the columns of the row that is the duplicate.
[ie: A:Q and S:AI].

I tried changing EntireRow to say Range("A:Q"), but it didn't like it. I'm
not sure what to say to change it.

Thanks again,

Sharon

"Sharon" wrote:

Hello,

I have four macros that I would like to consolidate into two. The first two
that should go together are the Sub Sort and Sub FindAndReplace. The second
two that I would like to be one command are HighlightFcstDups and
HighlightObsDups.

Can someone show me how to consolidate?

Here's the code:

'I would like these two macros to be consolidated into one macro:

Public Sub Sort()
Application.ScreenUpdating = False
ActiveSheet.Columns("A:Q").Select
Selection.Sort Key1:=Range("A1"), Order1:=xlAscending, Key2:=Range("B1") _
, Order2:=xlAscending, Key3:=Range("C1"), Order3:=xlAscending,
Header:= _
xlNo, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal, DataOption2:=xlSortNormal, DataOption3:= _
xlSortNormal
ActiveWindow.SmallScroll ToRight:=18
ActiveSheet.Columns("S:AI").Select
Selection.Sort Key1:=Range("S1"), Order1:=xlAscending, Key2:=Range("T1") _
, Order2:=xlAscending, Key3:=Range("U1"), Order3:=xlAscending,
Header:= _
xlGuess, OrderCustom:=1, MatchCase:=False,
Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal, DataOption2:=xlSortNormal, DataOption3:= _
xlSortNormal
Application.ScreenUpdating = True
Range("a1").Select
End Sub


Public Sub FindAndReplace()
Application.ScreenUpdating = False
Dim oColors As Range
With Worksheets("1_Import")
Set oColors = Union(.Range("B1:Q400"), Range("T1:AI400"))

oColors.Replace What:="green", Replacement:="G", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False
oColors.Replace What:="yellow", Replacement:="Y", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False
oColors.Replace What:="red", Replacement:="R", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False
oColors.Replace What:="no", Replacement:="NA", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False
Application.ScreenUpdating = True
End With
End Sub
----------------------------------------------------------------------

'These two macros I'd also like consolidated into one macro:

Sub HighlightFcstDups()

'Start at the currently selected cell
Range("a1").Select
x = ActiveCell.Row
y = x + 1

'Outside loop
Do While Cells(x, 1).Value < ""
'Inside loop
Do While Cells(y, 1).Value < ""
'Test for duplication:
'If the values of the third column (C) and the fifth column (E)
match in two rows (this part of the code I edited)
'delete the second row of the pair, otherwise go to the next row
until the end
If (Cells(x, 1).Value = Cells(y, 1).Value) Then

'FOR DUPLICATE DELETION: Uncommment the following line by
removing the apostrophe
'Cells(y, 3).EntireRow.Delete

'Shade the entire row green if it's a duplicate
'FOR DUPLICATE DELETION: Make the following line a comment
by adding an apostrophe
Cells(y, 1).EntireRow.Interior.ColorIndex = 4
Else

'FOR DUPLICATE DELETION: Uncomment the following line by
removing the apostrophe
'y = y + 1
End If

'FOR DUPLICATE DELETION: Make the following line a comment by
adding an apostrophe
y = y + 1
Loop
'increase the value of x by 1 to move the loop starting point to the
next row
x = x + 1
'reset y so it starts at the next row
y = x + 1
Loop

End Sub

Sub HighlightObsDups()

'Start at the currently selected cell
Range("S1").Select
x = ActiveCell.Row
y = x + 1

'Outside loop
Do While Cells(x, 19).Value < ""
'Inside loop
Do While Cells(y, 19).Value < ""
'Test for duplication:
'If the values of the third column (C) and the fifth column (E)
match in two rows (this part of the code I edited)
'delete the second row of the pair, otherwise go to the next row
until the end
If (Cells(x, 19).Value = Cells(y, 19).Value) Then

'FOR DUPLICATE DELETION: Uncommment the following line by
removing the apostrophe
'Cells(y, 3).EntireRow.Delete

'Shade the entire row green if it's a duplicate
'FOR DUPLICATE DELETION: Make the following line a comment
by adding an apostrophe
Cells(y, 19).EntireRow.Interior.ColorIndex = 4
Else

'FOR DUPLICATE DELETION: Uncomment the following line by
removing the apostrophe
'y = y + 1
End If

'FOR DUPLICATE DELETION: Make the following line a comment by
adding an apostrophe
y = y + 1
Loop
'increase the value of x by 1 to move the loop starting point to the
next row
x = x + 1
'reset y so it starts at the next row
y = x + 1
Loop

End Sub
----------------------------------------------------------------------------

Thanks for your help,

Sharon

Vasant Nanavati
Combining Macros into One Command
 
Try (untested):

Cells(y, 19).EntireRow.Resize(, 17).Interior.ColorIndex = 4

--

Vasant

"Sharon" wrote in message
...
I also forgot to ask:

On the Highlight Duplicates macros, it highlights the entire row [ie:
Cells(y, 1).EntireRow.Interior.ColorIndex =4] I would like to change the
property EntireRow to just be the columns of the row that is the
duplicate.
[ie: A:Q and S:AI].

I tried changing EntireRow to say Range("A:Q"), but it didn't like it.
I'm
not sure what to say to change it.

Thanks again,

Sharon

"Sharon" wrote:

Hello,

I have four macros that I would like to consolidate into two. The first
two
that should go together are the Sub Sort and Sub FindAndReplace. The
second
two that I would like to be one command are HighlightFcstDups and
HighlightObsDups.

Can someone show me how to consolidate?

Here's the code:

'I would like these two macros to be consolidated into one macro:

Public Sub Sort()
Application.ScreenUpdating = False
ActiveSheet.Columns("A:Q").Select
Selection.Sort Key1:=Range("A1"), Order1:=xlAscending,
Key2:=Range("B1") _
, Order2:=xlAscending, Key3:=Range("C1"), Order3:=xlAscending,
Header:= _
xlNo, OrderCustom:=1, MatchCase:=False,
Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal, DataOption2:=xlSortNormal,
DataOption3:= _
xlSortNormal
ActiveWindow.SmallScroll ToRight:=18
ActiveSheet.Columns("S:AI").Select
Selection.Sort Key1:=Range("S1"), Order1:=xlAscending,
Key2:=Range("T1") _
, Order2:=xlAscending, Key3:=Range("U1"), Order3:=xlAscending,
Header:= _
xlGuess, OrderCustom:=1, MatchCase:=False,
Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal, DataOption2:=xlSortNormal,
DataOption3:= _
xlSortNormal
Application.ScreenUpdating = True
Range("a1").Select
End Sub


Public Sub FindAndReplace()
Application.ScreenUpdating = False
Dim oColors As Range
With Worksheets("1_Import")
Set oColors = Union(.Range("B1:Q400"), Range("T1:AI400"))

oColors.Replace What:="green", Replacement:="G", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False
oColors.Replace What:="yellow", Replacement:="Y", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False
oColors.Replace What:="red", Replacement:="R", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False
oColors.Replace What:="no", Replacement:="NA", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False
Application.ScreenUpdating = True
End With
End Sub
----------------------------------------------------------------------

'These two macros I'd also like consolidated into one macro:

Sub HighlightFcstDups()

'Start at the currently selected cell
Range("a1").Select
x = ActiveCell.Row
y = x + 1

'Outside loop
Do While Cells(x, 1).Value < ""
'Inside loop
Do While Cells(y, 1).Value < ""
'Test for duplication:
'If the values of the third column (C) and the fifth column
(E)
match in two rows (this part of the code I edited)
'delete the second row of the pair, otherwise go to the next
row
until the end
If (Cells(x, 1).Value = Cells(y, 1).Value) Then

'FOR DUPLICATE DELETION: Uncommment the following line
by
removing the apostrophe
'Cells(y, 3).EntireRow.Delete

'Shade the entire row green if it's a duplicate
'FOR DUPLICATE DELETION: Make the following line a
comment
by adding an apostrophe
Cells(y, 1).EntireRow.Interior.ColorIndex = 4
Else

'FOR DUPLICATE DELETION: Uncomment the following line by
removing the apostrophe
'y = y + 1
End If

'FOR DUPLICATE DELETION: Make the following line a comment
by
adding an apostrophe
y = y + 1
Loop
'increase the value of x by 1 to move the loop starting point to
the
next row
x = x + 1
'reset y so it starts at the next row
y = x + 1
Loop

End Sub

Sub HighlightObsDups()

'Start at the currently selected cell
Range("S1").Select
x = ActiveCell.Row
y = x + 1

'Outside loop
Do While Cells(x, 19).Value < ""
'Inside loop
Do While Cells(y, 19).Value < ""
'Test for duplication:
'If the values of the third column (C) and the fifth column
(E)
match in two rows (this part of the code I edited)
'delete the second row of the pair, otherwise go to the next
row
until the end
If (Cells(x, 19).Value = Cells(y, 19).Value) Then

'FOR DUPLICATE DELETION: Uncommment the following line
by
removing the apostrophe
'Cells(y, 3).EntireRow.Delete

'Shade the entire row green if it's a duplicate
'FOR DUPLICATE DELETION: Make the following line a
comment
by adding an apostrophe
Cells(y, 19).EntireRow.Interior.ColorIndex = 4
Else

'FOR DUPLICATE DELETION: Uncomment the following line by
removing the apostrophe
'y = y + 1
End If

'FOR DUPLICATE DELETION: Make the following line a comment
by
adding an apostrophe
y = y + 1
Loop
'increase the value of x by 1 to move the loop starting point to
the
next row
x = x + 1
'reset y so it starts at the next row
y = x + 1
Loop

End Sub

--------------------------------------------------------------------------
--

Thanks for your help,

Sharon

Sharon
Combining Macros into One Command
 
I also forgot to ask:

On the Highlight Duplicates macros, it highlights the entire row [ie:
Cells(y, 1).EntireRow.Interior.ColorIndex =4] I would like to change the
property EntireRow to just be the columns of the row that is the duplicate.
[ie: A:Q and S:AI].

I tried changing EntireRow to say Range("A:Q"), but it didn't like it. I'm
not sure what to say to change it.

Thanks again,

Sharon

"Vasant Nanavati" wrote:

Just copy the text of the FindAndReplace sub (except fot he Sub ... End Sub
part) and past it into the Sort sub at the end, before the End Sub line.
Then delete the FindAndReplace sub.

Repeat for the other 2 subs.

--

Vasant

"Sharon" wrote in message
...
Hello,

I have four macros that I would like to consolidate into two. The first
two
that should go together are the Sub Sort and Sub FindAndReplace. The
second
two that I would like to be one command are HighlightFcstDups and
HighlightObsDups.

Can someone show me how to consolidate?

Here's the code:

'I would like these two macros to be consolidated into one macro:

Public Sub Sort()
Application.ScreenUpdating = False
ActiveSheet.Columns("A:Q").Select
Selection.Sort Key1:=Range("A1"), Order1:=xlAscending,
Key2:=Range("B1") _
, Order2:=xlAscending, Key3:=Range("C1"), Order3:=xlAscending,
Header:= _
xlNo, OrderCustom:=1, MatchCase:=False,
Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal, DataOption2:=xlSortNormal,
DataOption3:= _
xlSortNormal
ActiveWindow.SmallScroll ToRight:=18
ActiveSheet.Columns("S:AI").Select
Selection.Sort Key1:=Range("S1"), Order1:=xlAscending,
Key2:=Range("T1") _
, Order2:=xlAscending, Key3:=Range("U1"), Order3:=xlAscending,
Header:= _
xlGuess, OrderCustom:=1, MatchCase:=False,
Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal, DataOption2:=xlSortNormal,
DataOption3:= _
xlSortNormal
Application.ScreenUpdating = True
Range("a1").Select
End Sub


Public Sub FindAndReplace()
Application.ScreenUpdating = False
Dim oColors As Range
With Worksheets("1_Import")
Set oColors = Union(.Range("B1:Q400"), Range("T1:AI400"))

oColors.Replace What:="green", Replacement:="G", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False
oColors.Replace What:="yellow", Replacement:="Y", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False
oColors.Replace What:="red", Replacement:="R", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False
oColors.Replace What:="no", Replacement:="NA", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False
Application.ScreenUpdating = True
End With
End Sub
----------------------------------------------------------------------

'These two macros I'd also like consolidated into one macro:

Sub HighlightFcstDups()

'Start at the currently selected cell
Range("a1").Select
x = ActiveCell.Row
y = x + 1

'Outside loop
Do While Cells(x, 1).Value < ""
'Inside loop
Do While Cells(y, 1).Value < ""
'Test for duplication:
'If the values of the third column (C) and the fifth column
(E)
match in two rows (this part of the code I edited)
'delete the second row of the pair, otherwise go to the next
row
until the end
If (Cells(x, 1).Value = Cells(y, 1).Value) Then

'FOR DUPLICATE DELETION: Uncommment the following line by
removing the apostrophe
'Cells(y, 3).EntireRow.Delete

'Shade the entire row green if it's a duplicate
'FOR DUPLICATE DELETION: Make the following line a comment
by adding an apostrophe
Cells(y, 1).EntireRow.Interior.ColorIndex = 4
Else

'FOR DUPLICATE DELETION: Uncomment the following line by
removing the apostrophe
'y = y + 1
End If

'FOR DUPLICATE DELETION: Make the following line a comment by
adding an apostrophe
y = y + 1
Loop
'increase the value of x by 1 to move the loop starting point to
the
next row
x = x + 1
'reset y so it starts at the next row
y = x + 1
Loop

End Sub

Sub HighlightObsDups()

'Start at the currently selected cell
Range("S1").Select
x = ActiveCell.Row
y = x + 1

'Outside loop
Do While Cells(x, 19).Value < ""
'Inside loop
Do While Cells(y, 19).Value < ""
'Test for duplication:
'If the values of the third column (C) and the fifth column
(E)
match in two rows (this part of the code I edited)
'delete the second row of the pair, otherwise go to the next
row
until the end
If (Cells(x, 19).Value = Cells(y, 19).Value) Then

'FOR DUPLICATE DELETION: Uncommment the following line by
removing the apostrophe
'Cells(y, 3).EntireRow.Delete

'Shade the entire row green if it's a duplicate
'FOR DUPLICATE DELETION: Make the following line a comment
by adding an apostrophe
Cells(y, 19).EntireRow.Interior.ColorIndex = 4
Else

'FOR DUPLICATE DELETION: Uncomment the following line by
removing the apostrophe
'y = y + 1
End If

'FOR DUPLICATE DELETION: Make the following line a comment by
adding an apostrophe
y = y + 1
Loop
'increase the value of x by 1 to move the loop starting point to
the
next row
x = x + 1
'reset y so it starts at the next row
y = x + 1
Loop

End Sub
--------------------------------------------------------------------------
--

Thanks for your help,

Sharon

Sharon
Combining Macros into One Command
 
Yes! That works for my first set of data from columns A:Q (1-17).

I'm trying to modify that to also work for columns 19-35, but am unsure what
Cells(y, 19) is referring to.

Can you explain or tell me how to make this work for 19-35?

This is what I tried:

Cells(y, 19).EntireRow.Resize(19, 35).Interior.ColorIndex = 4

'and

Cells(y, 36).EntireRow.Resize(19, 35).Interior.ColorIndex = 4

Thanks so much,

Sharon
"Vasant Nanavati" wrote:

Try (untested):

Cells(y, 19).EntireRow.Resize(, 17).Interior.ColorIndex = 4

--

Vasant

"Sharon" wrote in message
...
I also forgot to ask:

On the Highlight Duplicates macros, it highlights the entire row [ie:
Cells(y, 1).EntireRow.Interior.ColorIndex =4] I would like to change the
property EntireRow to just be the columns of the row that is the
duplicate.
[ie: A:Q and S:AI].

I tried changing EntireRow to say Range("A:Q"), but it didn't like it.
I'm
not sure what to say to change it.

Thanks again,

Sharon

"Sharon" wrote:

Hello,

I have four macros that I would like to consolidate into two. The first
two
that should go together are the Sub Sort and Sub FindAndReplace. The
second
two that I would like to be one command are HighlightFcstDups and
HighlightObsDups.

Can someone show me how to consolidate?

Here's the code:

'I would like these two macros to be consolidated into one macro:

Public Sub Sort()
Application.ScreenUpdating = False
ActiveSheet.Columns("A:Q").Select
Selection.Sort Key1:=Range("A1"), Order1:=xlAscending,
Key2:=Range("B1") _
, Order2:=xlAscending, Key3:=Range("C1"), Order3:=xlAscending,
Header:= _
xlNo, OrderCustom:=1, MatchCase:=False,
Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal, DataOption2:=xlSortNormal,
DataOption3:= _
xlSortNormal
ActiveWindow.SmallScroll ToRight:=18
ActiveSheet.Columns("S:AI").Select
Selection.Sort Key1:=Range("S1"), Order1:=xlAscending,
Key2:=Range("T1") _
, Order2:=xlAscending, Key3:=Range("U1"), Order3:=xlAscending,
Header:= _
xlGuess, OrderCustom:=1, MatchCase:=False,
Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal, DataOption2:=xlSortNormal,
DataOption3:= _
xlSortNormal
Application.ScreenUpdating = True
Range("a1").Select
End Sub


Public Sub FindAndReplace()
Application.ScreenUpdating = False
Dim oColors As Range
With Worksheets("1_Import")
Set oColors = Union(.Range("B1:Q400"), Range("T1:AI400"))

oColors.Replace What:="green", Replacement:="G", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False
oColors.Replace What:="yellow", Replacement:="Y", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False
oColors.Replace What:="red", Replacement:="R", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False
oColors.Replace What:="no", Replacement:="NA", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False
Application.ScreenUpdating = True
End With
End Sub
----------------------------------------------------------------------

'These two macros I'd also like consolidated into one macro:

Sub HighlightFcstDups()

'Start at the currently selected cell
Range("a1").Select
x = ActiveCell.Row
y = x + 1

'Outside loop
Do While Cells(x, 1).Value < ""
'Inside loop
Do While Cells(y, 1).Value < ""
'Test for duplication:
'If the values of the third column (C) and the fifth column
(E)
match in two rows (this part of the code I edited)
'delete the second row of the pair, otherwise go to the next
row
until the end
If (Cells(x, 1).Value = Cells(y, 1).Value) Then

'FOR DUPLICATE DELETION: Uncommment the following line
by
removing the apostrophe
'Cells(y, 3).EntireRow.Delete

'Shade the entire row green if it's a duplicate
'FOR DUPLICATE DELETION: Make the following line a
comment
by adding an apostrophe
Cells(y, 1).EntireRow.Interior.ColorIndex = 4
Else

'FOR DUPLICATE DELETION: Uncomment the following line by
removing the apostrophe
'y = y + 1
End If

'FOR DUPLICATE DELETION: Make the following line a comment
by
adding an apostrophe
y = y + 1
Loop
'increase the value of x by 1 to move the loop starting point to
the
next row
x = x + 1
'reset y so it starts at the next row
y = x + 1
Loop

End Sub

Sub HighlightObsDups()

'Start at the currently selected cell
Range("S1").Select
x = ActiveCell.Row
y = x + 1

'Outside loop
Do While Cells(x, 19).Value < ""
'Inside loop
Do While Cells(y, 19).Value < ""
'Test for duplication:
'If the values of the third column (C) and the fifth column
(E)
match in two rows (this part of the code I edited)
'delete the second row of the pair, otherwise go to the next
row
until the end
If (Cells(x, 19).Value = Cells(y, 19).Value) Then

'FOR DUPLICATE DELETION: Uncommment the following line
by
removing the apostrophe
'Cells(y, 3).EntireRow.Delete

'Shade the entire row green if it's a duplicate
'FOR DUPLICATE DELETION: Make the following line a
comment
by adding an apostrophe
Cells(y, 19).EntireRow.Interior.ColorIndex = 4
Else

'FOR DUPLICATE DELETION: Uncomment the following line by
removing the apostrophe
'y = y + 1
End If

'FOR DUPLICATE DELETION: Make the following line a comment
by
adding an apostrophe
y = y + 1
Loop
'increase the value of x by 1 to move the loop starting point to
the
next row
x = x + 1
'reset y so it starts at the next row
y = x + 1
Loop

End Sub

--------------------------------------------------------------------------
--

Thanks for your help,

Sharon

Vasant Nanavati
Combining Macros into One Command
 
Cells(y, 19).EntireRow.Resize(, 17).Offset(, 19).Interior.ColorIndex = 4

--

Vasant


"Sharon" wrote in message
...
Yes! That works for my first set of data from columns A:Q (1-17).

I'm trying to modify that to also work for columns 19-35, but am unsure
what
Cells(y, 19) is referring to.

Can you explain or tell me how to make this work for 19-35?

This is what I tried:

Cells(y, 19).EntireRow.Resize(19, 35).Interior.ColorIndex = 4

'and

Cells(y, 36).EntireRow.Resize(19, 35).Interior.ColorIndex = 4

Thanks so much,

Sharon
"Vasant Nanavati" wrote:

Try (untested):

Cells(y, 19).EntireRow.Resize(, 17).Interior.ColorIndex = 4

--

Vasant

"Sharon" wrote in message
...
I also forgot to ask:

On the Highlight Duplicates macros, it highlights the entire row [ie:
Cells(y, 1).EntireRow.Interior.ColorIndex =4] I would like to change
the
property EntireRow to just be the columns of the row that is the
duplicate.
[ie: A:Q and S:AI].

I tried changing EntireRow to say Range("A:Q"), but it didn't like it.
I'm
not sure what to say to change it.

Thanks again,

Sharon

"Sharon" wrote:

Hello,

I have four macros that I would like to consolidate into two. The
first
two
that should go together are the Sub Sort and Sub FindAndReplace.
The
second
two that I would like to be one command are HighlightFcstDups and
HighlightObsDups.

Can someone show me how to consolidate?

Here's the code:

'I would like these two macros to be consolidated into one macro:

Public Sub Sort()
Application.ScreenUpdating = False
ActiveSheet.Columns("A:Q").Select
Selection.Sort Key1:=Range("A1"), Order1:=xlAscending,
Key2:=Range("B1") _
, Order2:=xlAscending, Key3:=Range("C1"),
Order3:=xlAscending,
Header:= _
xlNo, OrderCustom:=1, MatchCase:=False,
Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal, DataOption2:=xlSortNormal,
DataOption3:= _
xlSortNormal
ActiveWindow.SmallScroll ToRight:=18
ActiveSheet.Columns("S:AI").Select
Selection.Sort Key1:=Range("S1"), Order1:=xlAscending,
Key2:=Range("T1") _
, Order2:=xlAscending, Key3:=Range("U1"),
Order3:=xlAscending,
Header:= _
xlGuess, OrderCustom:=1, MatchCase:=False,
Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal, DataOption2:=xlSortNormal,
DataOption3:= _
xlSortNormal
Application.ScreenUpdating = True
Range("a1").Select
End Sub


Public Sub FindAndReplace()
Application.ScreenUpdating = False
Dim oColors As Range
With Worksheets("1_Import")
Set oColors = Union(.Range("B1:Q400"), Range("T1:AI400"))

oColors.Replace What:="green", Replacement:="G", LookAt:=xlPart,
_
SearchOrder:=xlByRows, MatchCase:=False
oColors.Replace What:="yellow", Replacement:="Y",
LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False
oColors.Replace What:="red", Replacement:="R", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False
oColors.Replace What:="no", Replacement:="NA", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False
Application.ScreenUpdating = True
End With
End Sub

----------------------------------------------------------------------

'These two macros I'd also like consolidated into one macro:

Sub HighlightFcstDups()

'Start at the currently selected cell
Range("a1").Select
x = ActiveCell.Row
y = x + 1

'Outside loop
Do While Cells(x, 1).Value < ""
'Inside loop
Do While Cells(y, 1).Value < ""
'Test for duplication:
'If the values of the third column (C) and the fifth
column
(E)
match in two rows (this part of the code I edited)
'delete the second row of the pair, otherwise go to the
next
row
until the end
If (Cells(x, 1).Value = Cells(y, 1).Value) Then

'FOR DUPLICATE DELETION: Uncommment the following
line
by
removing the apostrophe
'Cells(y, 3).EntireRow.Delete

'Shade the entire row green if it's a duplicate
'FOR DUPLICATE DELETION: Make the following line a
comment
by adding an apostrophe
Cells(y, 1).EntireRow.Interior.ColorIndex = 4
Else

'FOR DUPLICATE DELETION: Uncomment the following
line by
removing the apostrophe
'y = y + 1
End If

'FOR DUPLICATE DELETION: Make the following line a
comment
by
adding an apostrophe
y = y + 1
Loop
'increase the value of x by 1 to move the loop starting
point to
the
next row
x = x + 1
'reset y so it starts at the next row
y = x + 1
Loop

End Sub

Sub HighlightObsDups()

'Start at the currently selected cell
Range("S1").Select
x = ActiveCell.Row
y = x + 1

'Outside loop
Do While Cells(x, 19).Value < ""
'Inside loop
Do While Cells(y, 19).Value < ""
'Test for duplication:
'If the values of the third column (C) and the fifth
column
(E)
match in two rows (this part of the code I edited)
'delete the second row of the pair, otherwise go to the
next
row
until the end
If (Cells(x, 19).Value = Cells(y, 19).Value) Then

'FOR DUPLICATE DELETION: Uncommment the following
line
by
removing the apostrophe
'Cells(y, 3).EntireRow.Delete

'Shade the entire row green if it's a duplicate
'FOR DUPLICATE DELETION: Make the following line a
comment
by adding an apostrophe
Cells(y, 19).EntireRow.Interior.ColorIndex = 4
Else

'FOR DUPLICATE DELETION: Uncomment the following
line by
removing the apostrophe
'y = y + 1
End If

'FOR DUPLICATE DELETION: Make the following line a
comment
by
adding an apostrophe
y = y + 1
Loop
'increase the value of x by 1 to move the loop starting
point to
the
next row
x = x + 1
'reset y so it starts at the next row
y = x + 1
Loop

End Sub


--------------------------------------------------------------------------
--

Thanks for your help,

Sharon

Sharon
Combining Macros into One Command
 
Thank you so much for your help. It works beautifully.

Sharon

"Vasant Nanavati" wrote:

Cells(y, 19).EntireRow.Resize(, 17).Offset(, 19).Interior.ColorIndex = 4

--

Vasant


"Sharon" wrote in message
...
Yes! That works for my first set of data from columns A:Q (1-17).

I'm trying to modify that to also work for columns 19-35, but am unsure
what
Cells(y, 19) is referring to.

Can you explain or tell me how to make this work for 19-35?

This is what I tried:

Cells(y, 19).EntireRow.Resize(19, 35).Interior.ColorIndex = 4

'and

Cells(y, 36).EntireRow.Resize(19, 35).Interior.ColorIndex = 4

Thanks so much,

Sharon
"Vasant Nanavati" wrote:

Try (untested):

Cells(y, 19).EntireRow.Resize(, 17).Interior.ColorIndex = 4

--

Vasant

"Sharon" wrote in message
...
I also forgot to ask:

On the Highlight Duplicates macros, it highlights the entire row [ie:
Cells(y, 1).EntireRow.Interior.ColorIndex =4] I would like to change
the
property EntireRow to just be the columns of the row that is the
duplicate.
[ie: A:Q and S:AI].

I tried changing EntireRow to say Range("A:Q"), but it didn't like it.
I'm
not sure what to say to change it.

Thanks again,

Sharon

"Sharon" wrote:

Hello,

I have four macros that I would like to consolidate into two. The
first
two
that should go together are the Sub Sort and Sub FindAndReplace.
The
second
two that I would like to be one command are HighlightFcstDups and
HighlightObsDups.

Can someone show me how to consolidate?

Here's the code:

'I would like these two macros to be consolidated into one macro:

Public Sub Sort()
Application.ScreenUpdating = False
ActiveSheet.Columns("A:Q").Select
Selection.Sort Key1:=Range("A1"), Order1:=xlAscending,
Key2:=Range("B1") _
, Order2:=xlAscending, Key3:=Range("C1"),
Order3:=xlAscending,
Header:= _
xlNo, OrderCustom:=1, MatchCase:=False,
Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal, DataOption2:=xlSortNormal,
DataOption3:= _
xlSortNormal
ActiveWindow.SmallScroll ToRight:=18
ActiveSheet.Columns("S:AI").Select
Selection.Sort Key1:=Range("S1"), Order1:=xlAscending,
Key2:=Range("T1") _
, Order2:=xlAscending, Key3:=Range("U1"),
Order3:=xlAscending,
Header:= _
xlGuess, OrderCustom:=1, MatchCase:=False,
Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal, DataOption2:=xlSortNormal,
DataOption3:= _
xlSortNormal
Application.ScreenUpdating = True
Range("a1").Select
End Sub


Public Sub FindAndReplace()
Application.ScreenUpdating = False
Dim oColors As Range
With Worksheets("1_Import")
Set oColors = Union(.Range("B1:Q400"), Range("T1:AI400"))

oColors.Replace What:="green", Replacement:="G", LookAt:=xlPart,
_
SearchOrder:=xlByRows, MatchCase:=False
oColors.Replace What:="yellow", Replacement:="Y",
LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False
oColors.Replace What:="red", Replacement:="R", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False
oColors.Replace What:="no", Replacement:="NA", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False
Application.ScreenUpdating = True
End With
End Sub

----------------------------------------------------------------------

'These two macros I'd also like consolidated into one macro:

Sub HighlightFcstDups()

'Start at the currently selected cell
Range("a1").Select
x = ActiveCell.Row
y = x + 1

'Outside loop
Do While Cells(x, 1).Value < ""
'Inside loop
Do While Cells(y, 1).Value < ""
'Test for duplication:
'If the values of the third column (C) and the fifth
column
(E)
match in two rows (this part of the code I edited)
'delete the second row of the pair, otherwise go to the
next
row
until the end
If (Cells(x, 1).Value = Cells(y, 1).Value) Then

'FOR DUPLICATE DELETION: Uncommment the following
line
by
removing the apostrophe
'Cells(y, 3).EntireRow.Delete

'Shade the entire row green if it's a duplicate
'FOR DUPLICATE DELETION: Make the following line a
comment
by adding an apostrophe
Cells(y, 1).EntireRow.Interior.ColorIndex = 4
Else

'FOR DUPLICATE DELETION: Uncomment the following
line by
removing the apostrophe
'y = y + 1
End If

'FOR DUPLICATE DELETION: Make the following line a
comment
by
adding an apostrophe
y = y + 1
Loop
'increase the value of x by 1 to move the loop starting
point to
the
next row
x = x + 1
'reset y so it starts at the next row
y = x + 1
Loop

End Sub

Sub HighlightObsDups()

'Start at the currently selected cell
Range("S1").Select
x = ActiveCell.Row
y = x + 1

'Outside loop
Do While Cells(x, 19).Value < ""
'Inside loop
Do While Cells(y, 19).Value < ""
'Test for duplication:
'If the values of the third column (C) and the fifth
column
(E)
match in two rows (this part of the code I edited)
'delete the second row of the pair, otherwise go to the
next
row
until the end
If (Cells(x, 19).Value = Cells(y, 19).Value) Then

'FOR DUPLICATE DELETION: Uncommment the following
line
by
removing the apostrophe
'Cells(y, 3).EntireRow.Delete

'Shade the entire row green if it's a duplicate
'FOR DUPLICATE DELETION: Make the following line a
comment
by adding an apostrophe
Cells(y, 19).EntireRow.Interior.ColorIndex = 4
Else

'FOR DUPLICATE DELETION: Uncomment the following
line by
removing the apostrophe
'y = y + 1
End If

'FOR DUPLICATE DELETION: Make the following line a
comment
by
adding an apostrophe
y = y + 1
Loop
'increase the value of x by 1 to move the loop starting
point to
the
next row
x = x + 1
'reset y so it starts at the next row
y = x + 1
Loop

End Sub


--------------------------------------------------------------------------
--

Thanks for your help,

Sharon

Vasant Nanavati
Combining Macros into One Command
 
You're welcome; thanks for the feedback!

--

Vasant

"Sharon" wrote in message
...
Thank you so much for your help. It works beautifully.

Sharon

"Vasant Nanavati" wrote:

Cells(y, 19).EntireRow.Resize(, 17).Offset(, 19).Interior.ColorIndex = 4

--

Vasant


"Sharon" wrote in message
...
Yes! That works for my first set of data from columns A:Q (1-17).

I'm trying to modify that to also work for columns 19-35, but am
unsure
what
Cells(y, 19) is referring to.

Can you explain or tell me how to make this work for 19-35?

This is what I tried:

Cells(y, 19).EntireRow.Resize(19, 35).Interior.ColorIndex = 4

'and

Cells(y, 36).EntireRow.Resize(19, 35).Interior.ColorIndex = 4

Thanks so much,

Sharon
"Vasant Nanavati" wrote:

Try (untested):

Cells(y, 19).EntireRow.Resize(, 17).Interior.ColorIndex = 4

--

Vasant

"Sharon" wrote in message
...
I also forgot to ask:

On the Highlight Duplicates macros, it highlights the entire row
[ie:
Cells(y, 1).EntireRow.Interior.ColorIndex =4] I would like to
change
the
property EntireRow to just be the columns of the row that is the
duplicate.
[ie: A:Q and S:AI].

I tried changing EntireRow to say Range("A:Q"), but it didn't like
it.
I'm
not sure what to say to change it.

Thanks again,

Sharon

"Sharon" wrote:

Hello,

I have four macros that I would like to consolidate into two.
The
first
two
that should go together are the Sub Sort and Sub FindAndReplace.
The
second
two that I would like to be one command are HighlightFcstDups
and
HighlightObsDups.

Can someone show me how to consolidate?

Here's the code:

'I would like these two macros to be consolidated into one
macro:

Public Sub Sort()
Application.ScreenUpdating = False
ActiveSheet.Columns("A:Q").Select
Selection.Sort Key1:=Range("A1"), Order1:=xlAscending,
Key2:=Range("B1") _
, Order2:=xlAscending, Key3:=Range("C1"),
Order3:=xlAscending,
Header:= _
xlNo, OrderCustom:=1, MatchCase:=False,
Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal, DataOption2:=xlSortNormal,
DataOption3:= _
xlSortNormal
ActiveWindow.SmallScroll ToRight:=18
ActiveSheet.Columns("S:AI").Select
Selection.Sort Key1:=Range("S1"), Order1:=xlAscending,
Key2:=Range("T1") _
, Order2:=xlAscending, Key3:=Range("U1"),
Order3:=xlAscending,
Header:= _
xlGuess, OrderCustom:=1, MatchCase:=False,
Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal, DataOption2:=xlSortNormal,
DataOption3:= _
xlSortNormal
Application.ScreenUpdating = True
Range("a1").Select
End Sub


Public Sub FindAndReplace()
Application.ScreenUpdating = False
Dim oColors As Range
With Worksheets("1_Import")
Set oColors = Union(.Range("B1:Q400"), Range("T1:AI400"))

oColors.Replace What:="green", Replacement:="G",
LookAt:=xlPart,
_
SearchOrder:=xlByRows, MatchCase:=False
oColors.Replace What:="yellow", Replacement:="Y",
LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False
oColors.Replace What:="red", Replacement:="R",
LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False
oColors.Replace What:="no", Replacement:="NA",
LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False
Application.ScreenUpdating = True
End With
End Sub

----------------------------------------------------------------------

'These two macros I'd also like consolidated into one macro:

Sub HighlightFcstDups()

'Start at the currently selected cell
Range("a1").Select
x = ActiveCell.Row
y = x + 1

'Outside loop
Do While Cells(x, 1).Value < ""
'Inside loop
Do While Cells(y, 1).Value < ""
'Test for duplication:
'If the values of the third column (C) and the fifth
column
(E)
match in two rows (this part of the code I edited)
'delete the second row of the pair, otherwise go to
the
next
row
until the end
If (Cells(x, 1).Value = Cells(y, 1).Value) Then

'FOR DUPLICATE DELETION: Uncommment the
following
line
by
removing the apostrophe
'Cells(y, 3).EntireRow.Delete

'Shade the entire row green if it's a duplicate
'FOR DUPLICATE DELETION: Make the following line
a
comment
by adding an apostrophe
Cells(y, 1).EntireRow.Interior.ColorIndex = 4
Else

'FOR DUPLICATE DELETION: Uncomment the following
line by
removing the apostrophe
'y = y + 1
End If

'FOR DUPLICATE DELETION: Make the following line a
comment
by
adding an apostrophe
y = y + 1
Loop
'increase the value of x by 1 to move the loop starting
point to
the
next row
x = x + 1
'reset y so it starts at the next row
y = x + 1
Loop

End Sub

Sub HighlightObsDups()

'Start at the currently selected cell
Range("S1").Select
x = ActiveCell.Row
y = x + 1

'Outside loop
Do While Cells(x, 19).Value < ""
'Inside loop
Do While Cells(y, 19).Value < ""
'Test for duplication:
'If the values of the third column (C) and the fifth
column
(E)
match in two rows (this part of the code I edited)
'delete the second row of the pair, otherwise go to
the
next
row
until the end
If (Cells(x, 19).Value = Cells(y, 19).Value) Then

'FOR DUPLICATE DELETION: Uncommment the
following
line
by
removing the apostrophe
'Cells(y, 3).EntireRow.Delete

'Shade the entire row green if it's a duplicate
'FOR DUPLICATE DELETION: Make the following line
a
comment
by adding an apostrophe
Cells(y, 19).EntireRow.Interior.ColorIndex = 4
Else

'FOR DUPLICATE DELETION: Uncomment the following
line by
removing the apostrophe
'y = y + 1
End If

'FOR DUPLICATE DELETION: Make the following line a
comment
by
adding an apostrophe
y = y + 1
Loop
'increase the value of x by 1 to move the loop starting
point to
the
next row
x = x + 1
'reset y so it starts at the next row
y = x + 1
Loop

End Sub



--------------------------------------------------------------------------
--

Thanks for your help,

Sharon


All times are GMT +1. The time now is 04:17 PM.

Powered by vBulletin® Copyright ©2000 - 2025, Jelsoft Enterprises Ltd.
ExcelBanter.com