I created the macro shown below to search items on a column and
compare the items on the ActiveCell versus the value shown on the
following ActiveCell in the same column. Once a match was found the
macro will go back to the previous cell within the column and color
that particular cell and all the other cells within the row with the
same color (up to colunm 7). So far so good, and this is one of the
things that I want to do with the macro.

The problem is that I am trying to also put a line on the same cells
that are now in color and I can't find the right programing script to
do it. I just want a basic bottom line on all the cells that are also
changed to color

Please see the macro and let me know what am I missing. Thanks for
your help

Sub Sub_totals()
'
' Sub_totals Macro
' Macro recorded 5/2/2008 by Workstation
'

'
ScreenUpdating = False
FirstItem = ActiveCell.Value
SecondItem = ActiveCell.Offset(1, 0).Value
Offsetcount = 1
Do While ActiveCell < ""
If FirstItem = SecondItem Then
ActiveCell.Offset(-1, 0).Interior.ColorIndex = RGB(36, 0, 0)
ActiveCell.Offset(-1, 1).Interior.ColorIndex = RGB(36, 0, 0)
ActiveCell.Offset(-1, 2).Interior.ColorIndex = RGB(36, 0, 0)
ActiveCell.Offset(-1, 3).Interior.ColorIndex = RGB(36, 0, 0)
ActiveCell.Offset(-1, 4).Interior.ColorIndex = RGB(36, 0, 0)
ActiveCell.Offset(-1, 5).Interior.ColorIndex = RGB(36, 0, 0)
ActiveCell.Offset(-1, 6).Interior.ColorIndex = RGB(36, 0, 0)
ActiveCell.Offset(-1, 7).Interior.ColorIndex = RGB(36, 0, 0)
'ActiveCell.Offset(-1, 0).Borders (xlEdgeBottom)
'ActiveCell.Offset(-1, 0).LineStyle = xlContinuous
'ActiveCell.Weight = xlThin
'ActiveCell.ColorIndex = xlAutomatic
Offsetcount = Offsetcount + 1
SecondItem = ActiveCell.Offset(Offsetcount, 0).Value
Else
ActiveCell.Offset(Offsetcount, 0).Select
FirstItem = ActiveCell.Value
SecondItem = ActiveCell.Offset(1, 0).Value
Offsetcount = 1
End If
Loop
ScreenUpdating = True
End Sub

This worked when I tried it. See if it works for you.

ScreenUpdating = False
FirstItem = ActiveCell.Value
SecondItem = ActiveCell.Offset(1, 0).Value
Offsetcount = 1
Do While ActiveCell < ""
If FirstItem = SecondItem Then
ActiveCell.Offset(-1, 0).Interior.ColorIndex = RGB(36, 0, 0)
ActiveCell.Offset(-1, 1).Interior.ColorIndex = RGB(36, 0, 0)
ActiveCell.Offset(-1, 2).Interior.ColorIndex = RGB(36, 0, 0)
ActiveCell.Offset(-1, 3).Interior.ColorIndex = RGB(36, 0, 0)
ActiveCell.Offset(-1, 4).Interior.ColorIndex = RGB(36, 0, 0)
ActiveCell.Offset(-1, 5).Interior.ColorIndex = RGB(36, 0, 0)
ActiveCell.Offset(-1, 6).Interior.ColorIndex = RGB(36, 0, 0)
ActiveCell.Offset(-1, 7).Interior.ColorIndex = RGB(36, 0, 0)
Set x = ActiveCell.Offset(-1, 0) 'Inserted change
here
Set y = ActiveCell.Offset(-1, 7)
With Range(x, y).Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.Weight = xlThin
End With
'ActiveCell.Weight = xlThin
'ActiveCell.ColorIndex = xlAutomatic
Offsetcount = Offsetcount + 1
SecondItem = ActiveCell.Offset(Offsetcount, 0).Value
Else
ActiveCell.Offset(Offsetcount, 0).Select
FirstItem = ActiveCell.Value
SecondItem = ActiveCell.Offset(1, 0).Value
Offsetcount = 1
End If
Loop
ScreenUpdating = True
End Sub


" wrote:

I created the macro shown below to search items on a column and
compare the items on the ActiveCell versus the value shown on the
following ActiveCell in the same column. Once a match was found the
macro will go back to the previous cell within the column and color
that particular cell and all the other cells within the row with the
same color (up to colunm 7). So far so good, and this is one of the
things that I want to do with the macro.

The problem is that I am trying to also put a line on the same cells
that are now in color and I can't find the right programing script to
do it. I just want a basic bottom line on all the cells that are also
changed to color

Please see the macro and let me know what am I missing. Thanks for
your help

Sub Sub_totals()
'
' Sub_totals Macro
' Macro recorded 5/2/2008 by Workstation
'

'
ScreenUpdating = False
FirstItem = ActiveCell.Value
SecondItem = ActiveCell.Offset(1, 0).Value
Offsetcount = 1
Do While ActiveCell < ""
If FirstItem = SecondItem Then
ActiveCell.Offset(-1, 0).Interior.ColorIndex = RGB(36, 0, 0)
ActiveCell.Offset(-1, 1).Interior.ColorIndex = RGB(36, 0, 0)
ActiveCell.Offset(-1, 2).Interior.ColorIndex = RGB(36, 0, 0)
ActiveCell.Offset(-1, 3).Interior.ColorIndex = RGB(36, 0, 0)
ActiveCell.Offset(-1, 4).Interior.ColorIndex = RGB(36, 0, 0)
ActiveCell.Offset(-1, 5).Interior.ColorIndex = RGB(36, 0, 0)
ActiveCell.Offset(-1, 6).Interior.ColorIndex = RGB(36, 0, 0)
ActiveCell.Offset(-1, 7).Interior.ColorIndex = RGB(36, 0, 0)
'ActiveCell.Offset(-1, 0).Borders (xlEdgeBottom)
'ActiveCell.Offset(-1, 0).LineStyle = xlContinuous
'ActiveCell.Weight = xlThin
'ActiveCell.ColorIndex = xlAutomatic
Offsetcount = Offsetcount + 1
SecondItem = ActiveCell.Offset(Offsetcount, 0).Value
Else
ActiveCell.Offset(Offsetcount, 0).Select
FirstItem = ActiveCell.Value
SecondItem = ActiveCell.Offset(1, 0).Value
Offsetcount = 1
End If
Loop
ScreenUpdating = True
End Sub

Does this code do what you want?

Sub Sub_Totals()
Dim X As Long
Dim LastRow As Long
Dim LastCol As Long
With ActiveSheet
LastRow = .Cells(.Rows.Count, ActiveCell.Column).End(xlUp).Row
LastCol = ActiveCell.Column + 7
For X = ActiveCell.Row To LastRow
If .Cells(X, ActiveCell.Column).Value = _
.Cells(X + 1, ActiveCell.Column).Value Then
With .Range(.Cells(X - 1, ActiveCell.Column), _
.Cells(X - 1, LastCol))
.Interior.ColorIndex = 36
With .Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.Weight = xlThick
End With
End With
End If
Next
End With
End Sub

Rick



wrote in message
...
I created the macro shown below to search items on a column and
compare the items on the ActiveCell versus the value shown on the
following ActiveCell in the same column. Once a match was found the
macro will go back to the previous cell within the column and color
that particular cell and all the other cells within the row with the
same color (up to colunm 7). So far so good, and this is one of the
things that I want to do with the macro.

The problem is that I am trying to also put a line on the same cells
that are now in color and I can't find the right programing script to
do it. I just want a basic bottom line on all the cells that are also
changed to color

Please see the macro and let me know what am I missing. Thanks for
your help

Sub Sub_totals()
'
' Sub_totals Macro
' Macro recorded 5/2/2008 by Workstation
'

'
ScreenUpdating = False
FirstItem = ActiveCell.Value
SecondItem = ActiveCell.Offset(1, 0).Value
Offsetcount = 1
Do While ActiveCell < ""
If FirstItem = SecondItem Then
ActiveCell.Offset(-1, 0).Interior.ColorIndex = RGB(36, 0, 0)
ActiveCell.Offset(-1, 1).Interior.ColorIndex = RGB(36, 0, 0)
ActiveCell.Offset(-1, 2).Interior.ColorIndex = RGB(36, 0, 0)
ActiveCell.Offset(-1, 3).Interior.ColorIndex = RGB(36, 0, 0)
ActiveCell.Offset(-1, 4).Interior.ColorIndex = RGB(36, 0, 0)
ActiveCell.Offset(-1, 5).Interior.ColorIndex = RGB(36, 0, 0)
ActiveCell.Offset(-1, 6).Interior.ColorIndex = RGB(36, 0, 0)
ActiveCell.Offset(-1, 7).Interior.ColorIndex = RGB(36, 0, 0)
'ActiveCell.Offset(-1, 0).Borders (xlEdgeBottom)
'ActiveCell.Offset(-1, 0).LineStyle = xlContinuous
'ActiveCell.Weight = xlThin
'ActiveCell.ColorIndex = xlAutomatic
Offsetcount = Offsetcount + 1
SecondItem = ActiveCell.Offset(Offsetcount, 0).Value
Else
ActiveCell.Offset(Offsetcount, 0).Select
FirstItem = ActiveCell.Value
SecondItem = ActiveCell.Offset(1, 0).Value
Offsetcount = 1
End If
Loop
ScreenUpdating = True
End Sub

One way after selecting the "first item"
NOTE. As with yours, as written, this will ONLY do the cells BELOW the
active cell.

Sub colorifmatch()
mc = ActiveCell.Column
firstitem = ActiveCell.Value
lr = Cells(Rows.Count, mc).End(xlUp).Row
For i = ActiveCell.Row To lr
If Cells(i, mc) = firstitem Then
With Cells(i, mc).Resize(, 7)
.Interior.ColorIndex = RGB(36, 0, 0)
.Borders(xlEdgeBottom).LineStyle = xlContinuous
End With
End If
Next i
End Sub

--
Don Guillett
Microsoft MVP Excel
SalesAid Software

wrote in message
...
I created the macro shown below to search items on a column and
compare the items on the ActiveCell versus the value shown on the
following ActiveCell in the same column. Once a match was found the
macro will go back to the previous cell within the column and color
that particular cell and all the other cells within the row with the
same color (up to colunm 7). So far so good, and this is one of the
things that I want to do with the macro.

The problem is that I am trying to also put a line on the same cells
that are now in color and I can't find the right programing script to
do it. I just want a basic bottom line on all the cells that are also
changed to color

Please see the macro and let me know what am I missing. Thanks for
your help

Sub Sub_totals()
'
' Sub_totals Macro
' Macro recorded 5/2/2008 by Workstation
'

'
ScreenUpdating = False
FirstItem = ActiveCell.Value
SecondItem = ActiveCell.Offset(1, 0).Value
Offsetcount = 1
Do While ActiveCell < ""
If FirstItem = SecondItem Then
ActiveCell.Offset(-1, 0).Interior.ColorIndex = RGB(36, 0, 0)
ActiveCell.Offset(-1, 1).Interior.ColorIndex = RGB(36, 0, 0)
ActiveCell.Offset(-1, 2).Interior.ColorIndex = RGB(36, 0, 0)
ActiveCell.Offset(-1, 3).Interior.ColorIndex = RGB(36, 0, 0)
ActiveCell.Offset(-1, 4).Interior.ColorIndex = RGB(36, 0, 0)
ActiveCell.Offset(-1, 5).Interior.ColorIndex = RGB(36, 0, 0)
ActiveCell.Offset(-1, 6).Interior.ColorIndex = RGB(36, 0, 0)
ActiveCell.Offset(-1, 7).Interior.ColorIndex = RGB(36, 0, 0)
'ActiveCell.Offset(-1, 0).Borders (xlEdgeBottom)
'ActiveCell.Offset(-1, 0).LineStyle = xlContinuous
'ActiveCell.Weight = xlThin
'ActiveCell.ColorIndex = xlAutomatic
Offsetcount = Offsetcount + 1
SecondItem = ActiveCell.Offset(Offsetcount, 0).Value
Else
ActiveCell.Offset(Offsetcount, 0).Select
FirstItem = ActiveCell.Value
SecondItem = ActiveCell.Offset(1, 0).Value
Offsetcount = 1
End If
Loop
ScreenUpdating = True
End Sub