Transposing/combining columns with 2 headers

[Rob]

I'm having trouble transposing a spreadsheet with 2 column headers (dates for
the month across, with three sub columns beneath). I assume I'll need a VB
solution, but don't know how to construct them. Here is what I my original
data file looks like:

1-Dec-07 1-Dec-07 1-Dec-07 2-Dec-07 2-Dec-07 2-Dec-07
Page View Sessions Visitors Page View Sessions Visitors
LNX Code1 0 0 0 0 0 0
LNX Code2 20 1 1 10 2 2
LNX Code3 529 49 49 1756 109 107
LNX Code4 5294 431 431 4704 362 361

I want it to read like this:

Page View Sessions Visitors
LNX Code1 1-Dec-07 0 0 0
2-Dec-07 0 0 0
LNX Code2 1-Dec-07 20 1 1
2-Dec-07 10 2 2
LNX Code3 1-Dec-07 529 49 49
2-Dec-07 1756 109 107
LNX Code4 1-Dec-07 5294 431 431
2-Dec-07 4704 362 361

Any ideas?

 

[Joel]

Sub combinerows()

RowCount = 3
Columns("B:B").Insert
Do While Range("A" & RowCount) <> ""
Rows(RowCount + 1).Insert
Range("C" & (RowCount + 1)) = Range("F" & RowCount)
Range("D" & (RowCount + 1)) = Range("G" & RowCount)
Range("E" & (RowCount + 1)) = Range("H" & RowCount)
Range("F" & RowCount & ":H" & RowCount).ClearContents
Range("B" & RowCount) = Range("C1")
Range("B" & (RowCount + 1)) = Range("F1")
RowCount = RowCount + 2
Loop
Rows("1:1").Delete
Range("F1:H1").ClearContents

End Sub

 

[Rob]

This looks great. What if there are additional date columns out to the
right? Is there an easy way to append this, or rewrite it to continue the
loop until there is no more data to compile to the right as well?

 

[Herbert Seidenberg]

Try Pivot Table.
No formulas or VBA needed.
http://www.freefilehosting.net/download/3a6fl

 

[Joel]

I didn't fully test the code below but it should work. I added a column loop
to move across the wroksheet until no more data is found.

Sub combinerows()

RowCount = 3
Columns("B:B").Insert
Do While Range("A" & RowCount) <> ""
ColCount = 5 ' column F
NewRow = RowCount + 1
Range("B" & RowCount) = Range("C1")
Do While Cells(RowCount, ColCount) <> ""

Rows(NewRow).Insert
Range("C" & NewRow) = Cells(RowCount, ColCount)
Range("D" & NewRow) = Cells(RowCount, ColCount + 1)
Range("E" & NewRow) = Cells(RowCount, ColCount + 2)
Cells(RowCount, ColCount).ClearContents
Cells(RowCount, ColCount + 1).ClearContents
Cells(RowCount, ColCount + 2).ClearContents
Range("B" & NewRow) = Cells(1, ColCount)

NewRow = NewRow + 1
ColCount = ColCount + 3
Loop
RowCount = NewRow
Loop
Rows("1:1").Delete
Range("F1:H1").ClearContents

 

[Rob]

I had to make a minor correction to the ColCount line (change the 5 to a 6),
but otherwise this was exactly what I needed. Thanks!

 

[Joel]

I have problem counting to 6. I only have five fingers on one hand.