Hi Brian,
I'm based in the 'Naki at the moment & have been enjoying the long
weekend :-)
Hopefully the macro below does everything you want (I'm sure there are
ways of tidying it up but it should work as is - provided the line
breaks are all in the right place when you copy it).
fyi, I adapted the principles of using multiple ranges from
"CopyMultipleSelection", a macro written by John Walkenbach - an Excel
guru - which I downloaded in a file called "copymult.xls".

The macro below relies on the headers being in row 2 & the first row of
data being row 3.
btw, the "abs" means that it selects any of the cells that have an
absolute value of 2 ie it could = "-2" or "2". If this is what you want
to happen, change the first line of code from:
Range("a2:r" & Application.CountA(Range("r2:R" &
(Rows.Count)))).AutoFilter Field:=18, Criteria1:="2"
to
Range("a2:r" & Application.CountA(Range("r2:R" &
(Rows.Count)))).AutoFilter Field:=18, Criteria1:="=2", Operator:=xlOr,
_
Criteria2:="=-2"



Code:
--------------------
Sub ModifiedItemsToPrice()
application.screenupdating = false
'To filter for rows with "2" in col R, select the area in col C to M for each of these rows 7 remove the autofilter
Range("a2:r" & Application.CountA(Range("r2:R" & (Rows.Count)))).AutoFilter Field:=18, Criteria1:="2"
On Error GoTo NoTwosFound
Range("c3:m" & Application.CountA(Range("r2:R" & (Rows.Count)))).SpecialCells(xlCellTypeVisible).Se lect
On Error GoTo 0
Selection.AutoFilter
'*
Dim SelAreas() As Range
Dim NumAreas As Integer, i As Integer
' Store the areas as separate Range objects
NumAreas = Selection.Areas.Count
ReDim SelAreas(1 To NumAreas)
For i = 1 To NumAreas
Set SelAreas(i) = Selection.Areas(i)
Next
' Copy and paste each area (col C to M) as values, same for col R, and clear contents of col H.
For i = 1 To NumAreas
SelAreas(i).Copy
SelAreas(i).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Range("r" & SelAreas(i).Row & ":r" & SelAreas(i).Row + (SelAreas(i).Rows.Count - 1)).Copy
Range("r" & SelAreas(i).Row & ":r" & SelAreas(i).Row + (SelAreas(i).Rows.Count - 1)).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Range("h" & SelAreas(i).Row & ":h" & SelAreas(i).Row + (SelAreas(i).Rows.Count - 1)).ClearContents
'Format areas (col C to M)
With SelAreas(i).Interior
.ColorIndex = 37
.Pattern = xlSolid
End With
With SelAreas(i).Font
.ColorIndex = 3
.Bold = True
End With
Next i
'*
application.screenupdating = true
Exit Sub
NoTwosFound:
Selection.AutoFilter
MsgBox "There are no cells with the value of 2 in column R - now exiting sub without making any changes."
application.screenupdating = true
End Sub
--------------------


hth
Rob Brockett
NZ
Always learning & the best way to learn is to experience...


--
broro183
------------------------------------------------------------------------
broro183's Profile: http://www.excelforum.com/member.php...o&userid=30068
View this thread: http://www.excelforum.com/showthread...hreadid=508622