Combining Macros into One Command

G

Guest

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
 
V

Vasant Nanavati

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.
 
G

Guest

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
 
V

Vasant Nanavati

Try (untested):

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

--

Vasant

Sharon said:
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 said:
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
--------------------------------------------------------------------------
Click to expand...
--
Thanks for your help,

Sharon
Click to expand...
Click to expand...
 
G

Guest

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
 
G

Guest

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 said:
Try (untested):

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

--

Vasant

Sharon said:
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 said:
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
--------------------------------------------------------------------------
Click to expand...
--
Thanks for your help,

Sharon
Click to expand...
Click to expand...
Click to expand...
 
V

Vasant Nanavati

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

--

Vasant


Sharon said:
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 said:
Try (untested):

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

--

Vasant

Sharon said:
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

:

Hello,

I have four macros that I would like to consolidate into two. The
Click to expand...
first
two
that should go together are the Sub Sort and Sub FindAndReplace.
Click to expand...
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
Click to expand...
column
(E)
match in two rows (this part of the code I edited)
'delete the second row of the pair, otherwise go to the
Click to expand...
next
row
until the end
If (Cells(x, 1).Value = Cells(y, 1).Value) Then

'FOR DUPLICATE DELETION: Uncommment the following
Click to expand...
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
Click to expand...
comment
by
adding an apostrophe
y = y + 1
Loop
'increase the value of x by 1 to move the loop starting
Click to expand...
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
Click to expand...
column
(E)
match in two rows (this part of the code I edited)
'delete the second row of the pair, otherwise go to the
Click to expand...
next
row
until the end
If (Cells(x, 19).Value = Cells(y, 19).Value) Then

'FOR DUPLICATE DELETION: Uncommment the following
Click to expand...
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
Click to expand...
comment
by
adding an apostrophe
y = y + 1
Loop
'increase the value of x by 1 to move the loop starting
Click to expand...
point to
the
next row
x = x + 1
'reset y so it starts at the next row
y = x + 1
Loop

End Sub
Click to expand...
--------------------------------------------------------------------------
--

Thanks for your help,

Sharon
Click to expand...
Click to expand...
Click to expand...
 
G

Guest

Thank you so much for your help. It works beautifully.

Sharon

Vasant Nanavati said:
Cells(y, 19).EntireRow.Resize(, 17).Offset(, 19).Interior.ColorIndex = 4

--

Vasant


Sharon said:
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 said:
Try (untested):

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

--

Vasant

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

:

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
Click to expand...
Click to expand...
Click to expand...
 
V

Vasant Nanavati

You're welcome; thanks for the feedback!

--

Vasant

Sharon said:
Thank you so much for your help. It works beautifully.

Sharon

Vasant Nanavati said:
Cells(y, 19).EntireRow.Resize(, 17).Offset(, 19).Interior.ColorIndex = 4

--

Vasant


Sharon said:
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
Click to expand...
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
:

Try (untested):

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

--

Vasant

I also forgot to ask:

Cells(y, 1).EntireRow.Interior.ColorIndex =4] I would like to
Click to expand...
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

:

Hello,

I have four macros that I would like to consolidate into two.
Click to expand...
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",
Click to expand...
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
Click to expand...
the
next
row
until the end
If (Cells(x, 1).Value = Cells(y, 1).Value) Then

'FOR DUPLICATE DELETION: Uncommment the
Click to expand...
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
Click to expand...
the
next
row
until the end
If (Cells(x, 19).Value = Cells(y, 19).Value) Then

'FOR DUPLICATE DELETION: Uncommment the
Click to expand...
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
Click to expand...
--------------------------------------------------------------------------
--

Thanks for your help,

Sharon
Click to expand...
Click to expand...
Click to expand...
Click to expand...
Click to expand...
Click to expand...
 

Ask a Question

Want to reply to this thread or ask your own question?

You'll need to choose a username for the site, which only take a couple of moments. After that, you can post your question and our members will help you out.

Ask a Question

Similar Threads

Excel VBA help: Text file formatting 19
Data Cleanse Macro Running Very Slow 0
Using the FIND function in a loop 2
conso macro 0
Defining Range using Cells 8
apply Macro to all sheets in workbook - loop 3
Loop worksheets workbook 1
For Eachcell in Range tranpose comma seperated values to a list in D 4

Top