Columns To Rows

[Guest]

the data base I'm dealing with needs to elimanate every third row
and here is the tough one; the destination is cell interior color dependant.
Meaning that every group of three, or 6, or 9 etc. cells in any column that is
interior colored by the boss has to go to a specific invoice, like Invoice
"Alpine". into two cells next to each other.

Example:

Buy Report:

A B C D E F G H
Product Jane Jim Mike Fred Bob Dave SKip
#1 10 5 4 6 20 33 100
Price 1.50 1.50 1.50 1.75 1.50 1.25 1.30
boxs 2 1 1 1 4 5 9
#2
Price The Same Down and Over #'s are meaningless
Boxs Except that the "boxes" rows need to be left out
#3 of the copy process. I'll use Skips Numbers to
Price Represent Three Selected and colored Red Cells
Boxs It could be six down or more, but always in threes
#4
Price
Boxs
#5
Price
Boxs
#6
Price
Boxs
#7
Price
Boxs
#8
Price
Boxs
#9
Price
Boxs

INVOICE ALPINE

Product NUMBERS PRICE TOTALS
100 1.30 40.00

Blue Colored cells would go to Say Ponderosa Invoice.

I hope I'm not asking too much. I have gotten cells to copy from columns to
rows but its pretty messy and I cant use the cell interior color or eliminate
the third row. Part of the problem is that The first group at the top its the
fourth row because of the column heading. Column A is also a heading column for
rows.

I would Also Like it to delete the color in the invoice and then Print when finished

 

[Tom Ogilvy]

Dim i as long, j as long
Dim cell as Range, rng as Range
for i = 2 to 100 step 3
for j = 2 to 8
set cell = Cells(i,j)
Select Case cell.Interior.ColorIndex
Case 1
' Invoice A
cell.Resize(2,1).copy
set rng = worksheets("A").Range("B9")
if not isempty(rng) then
if isempty(rng(2) then
set rng = rng.offset(1,0)
else
set rng = rng.End(xldown)(2)
end if
end if
rng.PasteSpecial paste:=xlValue, Transpose:=True
Case 2
' Invoice B
cell.Resize(2,1).copy
set rng = worksheets("B").Range("B9")
if not isempty(rng) then
if isempty(rng(2) then
set rng = rng.offset(1,0)
else
set rng = rng.End(xldown)(2)
end if
end if
rng.PasteSpecial paste:=xlValue, Transpose:=True


I am sure the code could be significantly reduced with the first hand
knowledge of the situation you have. But this should give you some
insights.