Macro to convert data from horizontal to vertical

[hmrfatcat]

I need to convert data from horisontal to vertical to be able to analyse data in a pivot-table.

I found some help in this article: http://www.mrexcel.com/articles/pivot-table-horizontal-to-vertical.php

Where the following code is mentioned:

Public Sub TransformData()
' Copyright 1999 MrExcel.com
Sheets("Sheet2").Select
Range("A1").CurrentRegion.Clear
Sheets("Sheet1").Select
Range("A1:B1").Copy Destination:=Sheets("Sheet2").Range("A1")
Sheets("Sheet2").Select
Range("C1").Value = "Qtr"
Range("D1").Value = "Sales"
Sheets("Sheet1").Select
FinalRow = Range("A16000").End(xlUp).Row
NextRow = 2
LastRow = FinalRow
' Loop through the data columns
For i = 3 To 6
ThisCol = Mid("ABCDEFGHIJK", i, 1)
' Copy the left columns from sheet1 to sheet2
Range("A2:B" & FinalRow).Copy Destination:= _
Sheets("Sheet2").Range("A" & NextRow)
' Copy the header from ThisCol to column C
Range(ThisCol & "1").Copy Destination:= _
Sheets("Sheet2").Range("C" & NextRow & ":C" & LastRow)
' Copy the data for this quarter to column D
Range(ThisCol & "2:" & ThisCol & FinalRow).Copy _
Destination:=Sheets("Sheet2").Range("D" & NextRow)
NextRow = LastRow + 1
LastRow = NextRow + FinalRow - 2
Next i
Sheets("Sheet2").Select
End Sub


It is the part: For i = 3 To 6 ThisCol = Mid("ABCDEFGHIJK", i, 1)
that is the problem for me as my data is in 32 colums (ie. For i = 2 To 32), but I can only get the Mid("ABC...Z", i, 1) to work for 26 colums, and I need som more.

Does anybody have an idea how to solve my problem?



Best regards


HMR

 

[wigi]

Hi

Use column numbers instead:

' Copy the header from ThisCol to column C
Range(ThisCol & "1").Copy ...

could become:

' Copy the header from ThisCol to column C
Cells(1, i).Copy ...

no need for a column name since you use a number.

Wigi

PS: thát macro hurts the eyes of an Excel pro... ;-0

 

[hmrfatcat]

Dear Wigi.

Thanks for your reply - and yes it hurts but I just pasted the code from mrexcel - and it was prette late in the evening.

But my problem was not solved by your suggestion, or perhaps I used it wrong.

Please have a look at my code: Nicely presented

Sub TransformData()

Sheets("Sheet2").Select
Range("A1").CurrentRegion.Clear
Sheets("Sheet1").Select
Range("A1").Copy Destination:=Sheets("Sheet2").Range("A1")
Sheets("Sheet2").Select
Range("c1").Value = "Qrt"
Range("d1").Value = "Sales"
Sheets("Sheet1").Select
FinalRow = Range("A16000").End(xlUp).Row
NextRow = 2
LastRow = FinalRow

' Loop through the data columns
For i = 2 To 31
ThisCol = Mid("ABCDEFGHIJKLMNOPQRSTUVWXYZ", i, 1)

' Copy the left columns from sheet1 to sheet2
Range("A2:b" & FinalRow).Copy Destination:= _
Sheets("Sheet2").Range("A" & NextRow)

' Copy the header from ThisCol to column C
Range(ThisCol & "1").Copy Destination:= _
Sheets("Sheet2").Range("C" & NextRow & ":C" & LastRow)

' Copy the data for this quarter to column D
Range(ThisCol & "2:" & ThisCol & FinalRow).Copy _
Destination:=Sheets("Sheet2").Range("D" & NextRow)

NextRow = LastRow + 1
LastRow = NextRow + FinalRow - 2
Next i
Sheets("Sheet2").Select

End Sub



It is the section highlighted with red that does not work when I exceed 26 columns - and I get the VBA 400 fault.

Do you have an idea of how to get around that problem or do others?


Thanks in advance to anybody

 

[wigi]

As "ABCDEFGHIJKLMNOPQRSTUVWXYZ" only has 26 characters, you can't ask for the 27th, 28th and so on...

I should have mentioned that you must remove the line:

ThisCol = Mid("ABCDEFGHIJKLMNOPQRSTUVWXYZ", i, 1)

Besides that, where in fact did you implement my suggestion?

 

[hmrfatcat]

Dear Wigi.

I tried as you suggested:

Sheets("Sheet2").Select
Range("A1").CurrentRegion.Clear
Sheets("Sheet1").Select
Range("A1").Copy Destination:=Sheets("Sheet2").Range("A1")
Sheets("Sheet2").Select
Range("c1").Value = "Dato"
Range("d1").Value = "Aktivitet"
Sheets("Sheet1").Select
FinalRow = Range("A16000").End(xlUp).Row
NextRow = 2
LastRow = FinalRow

' Loop through the data columns
For i = 2 To 32

'ThisCol = Mid("ABCDEFGHIJKLMNOPQRSTUVWXYZ", i, 1)
' Copy the left columns from sheet1 to sheet2
Range("A2:b" & FinalRow).Copy Destination:= _
Sheets("Sheet2").Range("A" & NextRow)

' Copy the header from ThisCol to column C
Cells(1, i).Copy Destination:= _
Sheets("Sheet2").Range("C" & NextRow & ":C" & LastRow)

' Copy the data for this quarter to column D
Range(ThisCol & "2:" & ThisCol & FinalRow).Copy _
Destination:=Sheets("Sheet2").Range("D" & NextRow)

NextRow = LastRow + 1
LastRow = NextRow + FinalRow - 2
Next i
Sheets("Sheet2").Select
End Sub


But I still the the VBA 400 fault.


Any suggestions to what I do wrong or to improvements?



BR HMR

 

[wigi]

HMR,

You're still using ThisCol?

Range(ThisCol & "2:" & ThisCol & FinalRow).Copy ...

Why?

You also need to use the Cells-logic in that line of code.