copying colored cells

[mns]

Hi,
I am trying to copy lots of cells to a new worksheet. These cells have their
font color red.(they happen to be table names). Tables do not have standart
rows, so i can use a for loop thing here or at least can image how to set
it.
All I want to scan just A column, find red colored text and copy the text to
another workbook. Tried to to it manually but i happen to make mistakes

ps:as these are the table rows, they only have data in their Ax cells.
B,C,D.. are empty

note: Cannot filter to sort them out cause i will copy the table footers,
which contain prices. so cant kill the style a table looks like this:

table_name
product_name price stock total
product1 4 10 40
product2 3 5 15
product3 5 2 10

TotalSUM 65


I am trying to do is, to get a list in a new worksheet like,

A B
1 table_name1 TotalSUM1
2 table_name2 TotalSUM2
3


Thanx in advance

 

[joel]

Try this code. It may have to be modifiied slightly because you hav
footers that you didn't post.


Sub GetTotals()

Set SourceSht = Sheets("sheet1")
Set DestSht = Sheets("sheet2")

NewRow = 1
With SourceSht
LastRow = .Range("A" & Rows.Count).End(xlUp).Row
For RowCount = 1 To LastRow
'skip rows with column A blank
If .Range("A" & RowCount) <> "" Then
'if column A is the conly column with data
'then this row contains the table name
LastCol = .Cells(RowCount, Columns.Count) _
.End(xlToLeft).Column
If LastCol = 1 Then
TableName = .Range("A" & RowCount)
Else
'check if column a contains TotalSUM
If UCase(.Range("A" & RowCount)) = "TOTALSUM" Then
Total = .Range("D" & RowCount)
'put data in destination sheet
With DestSht
.Range("A" & NewRow) = TableName
.Range("B" & NewRow) = Total
NewRow = NewRow + 1
End With
End If
End If
End If
Next RowCount
End With

End Sub

 

[mns]

Joel! Thank you Worked like a charm

 

[mns]

Ooopsss I had some duplicates with the values that code genrated for me
And I wonder if I can paste the formulas or adresses? so its easier to find
out what
wents wrong and where it goes wrong

Joel! Thank you Worked like a charm

Try this code. It may have to be modifiied slightly because you have
footers that you didn't post.


Sub GetTotals()

Set SourceSht = Sheets("sheet1")
Set DestSht = Sheets("sheet2")

NewRow = 1
With SourceSht
LastRow = .Range("A" & Rows.Count).End(xlUp).Row
For RowCount = 1 To LastRow
'skip rows with column A blank
If .Range("A" & RowCount) <> "" Then
'if column A is the conly column with data
'then this row contains the table name
LastCol = .Cells(RowCount, Columns.Count) _
.End(xlToLeft).Column
If LastCol = 1 Then
TableName = .Range("A" & RowCount)
Else
'check if column a contains TotalSUM
If UCase(.Range("A" & RowCount)) = "TOTALSUM" Then
Total = .Range("D" & RowCount)
'put data in destination sheet
With DestSht
.Range("A" & NewRow) = TableName
.Range("B" & NewRow) = Total
NewRow = NewRow + 1
End With
End If
End If
End If
Next RowCount
End With

End Sub


--
joel
------------------------------------------------------------------------
joel's Profile: 229
View this thread: http://www.thecodecage.com/forumz/showthread.php?t=181062

Microsoft Office Help

.