Copy rows with Interior Colour Index values 15 and 35 to a new she

[manfareed]

Hi ,

I have a spreadsheet with many "tabs" from which I need to extract to a
summary sheet the rows which have interior colour index value = 15 and 35.
Value 15 refers to the client and 35 to Gross Margin.

Each extract to the summary sheet should have a subheading equal to the tab
name from which it wa extracted i.e.
Birmingham
Client1
Grossmargin
Client 2
Gross Margin
etc.

Manchester
Client1
Gross Margin
etc.

Many Thanks,

 

[Joel]

The code will look something like the code below. Add a Worksheet call
Summary.

LastRow = Sheets("Summary").Range("A" & rows.Count).end(Xlup).Row
NewRow = LastRow + 1

For each Sht in sheets
if Sht.Name <> "Summary" then
LastRow = Sht.Range("A" & rows.Count).end(Xlup).Row
for RowCount = 1 to LastRow
if Sht.Range("A" & RowCount).Interior.colorindex = 15 or _
Sht.Range("A" & RowCount).Interior.colorindex = 15 then

Sht.Rows(RowCount).Copy _
Destination:=Sheets("Summary").Rows(NewRow)
NewRow = Newrow + 1
end if
next RowCount
end if
next Sht

 

[manfareed]

Hi Joel,

Many Thanks for your quick reply.

Nearly there I just need a subheading before it copies rows with colour
index 15 and 35. Subheading should be same as the "sheet name " from which
the data is being copied from. Sheet name is a place name eg. Birmingham.

How do include this in the code which you so kindly provided.

Thanks

 

[Joel]

Sorry, I forgot to copy the sheet name like you originally posted

Sub test()

NewRow = Sheets("Summary").Range("A" & Rows.Count).End(xlUp).Row

For Each Sht In Sheets
If Sht.Name <> "Summary" Then
With Sht
LastRow = .Range("A" & Rows.Count).End(xlUp).Row

For RowCount = 1 To LastRow
If .Range("A" & RowCount).Interior.ColorIndex = 15 Or _
.Range("A" & RowCount).Interior.ColorIndex = 15 Then

LastCol = .Cells(RowCount.Columns.Count).End(xlToLeft).Column
Sheets("Summary").Range("A" & NewRow) = .Name
.Range(.Range("A" & RowCount), .Cells(RowCount,
LastCol)).Copy _
Destination:=Sheets("Summary").Range("B" & NewRow)
NewRow = NewRow + 1
End If
Next RowCount
End With
End If
Next Sht

End Sub

 

[manfareed]

Hi,

I get the following error ...

"Object required (Error 424)"

Its on the following line.

LastCol = .Cells(RowCount.Columns.Count).End(xlToLeft).Column

Thanks

 

[manfareed]

Hi ,

How would I change the code so that the data is copied as "paste special"
i.e. values only to the "Summary" sheet.

thanks

 

[Joel]

Looks like I had a period instead of a comma
from:
LastCol = .Cells(RowCount.Columns.Count).End(xlToLeft).Column
to:
LastCol = .Cells(RowCount,Columns.Count).End(xlToLeft).Column


to make PasteSpecial
from:
.Range(.Range("A" & RowCount), .Cells(RowCount,
LastCol)).Copy _
Destination:=Sheets("Summary").Range("B" & NewRow)

to:
.Range(.Range("A" & RowCount), .Cells(RowCount,
LastCol)).Copy
Sheets("Summary").Range("B" & NewRow).PasteSpecial _
Paste:=xlPasteValues

 

[manfareed]

Many Thanks...

Looks like I had a period instead of a comma
from:
LastCol = .Cells(RowCount.Columns.Count).End(xlToLeft).Column
to:
LastCol = .Cells(RowCount,Columns.Count).End(xlToLeft).Column


to make PasteSpecial
from:
.Range(.Range("A" & RowCount), .Cells(RowCount,
LastCol)).Copy _
Destination:=Sheets("Summary").Range("B" & NewRow)

to:
.Range(.Range("A" & RowCount), .Cells(RowCount,
LastCol)).Copy
Sheets("Summary").Range("B" & NewRow).PasteSpecial _
Paste:=xlPasteValues