Looking for code to transpose data

[Drew]

Hello all,
I'm hoping someone can help me out utilizing code to transpose monthly data. I've got five years worth of data sorted by year but the months are spread across columns. I would like to have one column for amount and a new column to distinguish what month that was transposed.
I'm sure I may not be explaining it properly, but hopefully the attached can help out....
Thanks,
Drew

Book1
	A	B	C	D	E	F	G	H	I	J
1	data in the master sheet
2	company	acct_no	rollup_cd	rollup_lname	reclass_ind	year	meb_jan	meb_feb	meb_mar	etc..
3	001	000999990	A9%%%0A1	Drew Acct 0	YY	2000	(2.57)	(1.46)	(149.45)
4	001	000999991	A9%%%0A1	Drew Acct 1	YY	2001	448.62	15,648.49	224.04
5	001	000999992	A9%%%0A1	Drew Acct 2	YY	2002	(102.28)	(766.17)	(8,954.02)
6	Data goes down approx 3k lines (approx 400 rows per year) sorted by year
7
8
9	copy data to another worksheet as follows..
10	company	acct_no	rollup_cd	rollup_lname	reclass_ind	year	meb	mth
11	001	000999990	A9%%%0A1	Drew Acct 0	YY	2000	(2.57)	meb_jan
12	001	000999991	A9%%%0A1	Drew Acct 1	YY	2001	448.62	meb_jan
13	001	000999992	A9%%%0A1	Drew Acct 2	YY	2002	(102.28)	meb_jan
14	001	000999990	A9%%%0A1	Drew Acct 0	YY	2000	(1.46)	meb_feb
15	001	000999991	A9%%%0A1	Drew Acct 1	YY	2001	15,648.49	meb_feb
16	001	000999992	A9%%%0A1	Drew Acct 2	YY	2002	(766.17)	meb_feb
17	001	000999990	A9%%%0A1	Drew Acct 0	YY	2000	(149.45)	meb_mar
18	001	000999991	A9%%%0A1	Drew Acct 1	YY	2001	224.04	meb_mar
19	001	000999992	A9%%%0A1	Drew Acct 2	YY	2002	(8,954.02)	meb_mar
Sheet2

 

[BrianB]

Try this :-

'========================================================
'- TRANSFER DATA COLUMN-WISE TO ROW-WISE
'- Brian Baulsom May 2005
'========================================================
Option Base 1
Sub test()
    Dim FromSheet As Worksheet  ' called "Sheet1"
    Dim FromRow As Long
    Dim NumberOfMonths As Integer   ' ** amend below
    Dim MonthName As Variant        ' ** amend below
    Dim ThisMonth As String
    Dim FromCol As Long
    Dim ThisValue As Double
    Dim Col1, Col2, Col3, Col4, Col5, Col6
    '--
    Dim ToSheet As Worksheet    ' called "New"
    Dim ToRow As Long
    Dim ToCol As Long
    Dim m As Integer
    '-----------------------------------------------------
    Application.Calculation = xlCalculationManual
    Set FromSheet = Worksheets("Sheet1")               '**
    FromRow = 2
    NumberOfMonths = 3                                 '**
    MonthName = Array("meb_jan", "meb_feb", "meb_mar") '**
    Set ToSheet = Worksheets("new")                    '**
    ToRow = 2
    '-----------------------------------------------------
    '- do down rows
    While FromSheet.Cells(FromRow, 1).Value <> ""
        Col1 = FromSheet.Cells(FromRow, 1).Value
        Col2 = FromSheet.Cells(FromRow, 2).Value
        Col3 = FromSheet.Cells(FromRow, 3).Value
        Col4 = FromSheet.Cells(FromRow, 4).Value
        Col5 = FromSheet.Cells(FromRow, 5).Value
        Col6 = FromSheet.Cells(FromRow, 6).Value
        '- go across columns * transfer data
        For m = 1 To NumberOfMonths
            ThisMonth = MonthName(m)
            FromCol = m + 6
            ThisValue = FromSheet.Cells(FromRow, FromCol).Value
            If ThisValue <> 0 Then
                ToSheet.Cells(ToRow, 1).Value = Col1
                ToSheet.Cells(ToRow, 2).Value = Col2
                ToSheet.Cells(ToRow, 3).Value = Col3
                ToSheet.Cells(ToRow, 4).Value = Col4
                ToSheet.Cells(ToRow, 5).Value = Col5
                ToSheet.Cells(ToRow, 6).Value = Col6
                ToSheet.Cells(ToRow, 7).Value = ThisValue
                ToSheet.Cells(ToRow, 8).Value = ThisMonth
                ToRow = ToRow + 1
            End If
        Next
        FromRow = FromRow + 1
    Wend
    MsgBox ("Done.")
    Application.Calculation = xlCalculationAutomatic
End Sub