Transposing in VBA

[dataminer]

Hello VBA experts,

I am VBA beginner and need help with transposing columns in Excel. The data looks like that:






101

HAKKLIHAD







JAHUD







TANG





102

IHUHOOLDUSVAHENDID







KALA







KONSERVID







KUIVATATUD







PÄRM






There are hundreds of such ID-s with corresponding list of values. Instead of that I need the following:
HAKKLIHAD JAHUD TANG
IHUHOOLDUSVAHENDID KALA KONSERVID KUIVATATUD PÄRM

So, the values of each ID are on separate row.
Is there any algorithm that enables to do that?

Thank you in advance!

[stanleydgrom]

dataminer,

Welcome to the VBA Express forum.

I was not sure what the results should look like.

With your raw data in columns A and B, beginning in row 1, the below macro using two arrays in memory will write the results beginning in cell D1.

See if the following does what you want.

Please TEST this FIRST in a COPY of your workbook (always make a backup copy before trying new code, you never know what you might lose).

1. Copy the below code
2. Open your NEW workbook
3. Press the keys ALT + F11 to open the Visual Basic Editor
4. Press the keys ALT + I to activate the Insert menu
5. Press M to insert a Standard Module
6. Where the cursor is flashing, paste the code
7. Press the keys ALT + Q to exit the Editor, and return to Excel
8. To run the macro from Excel press ALT + F8 to display the Run Macro Dialog. Double Click the macro's name to Run it.





Option Explicit
Sub ReorgData()
' stanleydgrom, 09/05/2013
' http://www.vbaexpress.com/forum/showthread.php?47419-Transposing-in-VBA
Dim a As Variant, o As Variant
Dim i As Long, ii As Long, nr As Long, nc As Long
a = Cells(1).CurrentRegion
ReDim o(1 To UBound(a, 1), 1 To Columns.Count - UBound(a, 1))
For i = 1 To UBound(a, 1)
If a(i, 1) <> "" Then
nr = nr + 1
ii = ii + 1
o(ii, 1) = a(i, 1)
o(ii, 2) = a(i, 2)
nc = 2
Else
nc = nc + 1
o(nr, nc) = a(i, 2)
End If
Next i
Range("D1").Resize(UBound(o, 1), UBound(o, 2)) = o
Columns.AutoFit
End Sub



Before you use the macro with Excel 2007 or newer, save your workbook, Save As, a macro enabled workbook with the file extension .xlsm

Then run the ReorgData macro.

[Teeroy]

Try the following, it will transpose the data onto a sheet called "Output".


Sub teeroy()
Set Rng = Intersect(ActiveSheet.UsedRange, ActiveSheet.Columns("A")).SpecialCells(xlCellTypeBlanks)
On Error Resume Next
WorksheetExists = (Sheets("Output").Name <> "")
If WorksheetExists Then
Set output = Sheets("Output")
Else
Set output = Sheets.Add
output.Name = "Output"
End If
For i = 1 To Rng.Areas.Count
Rng.Areas(i).Offset(-1, 1).Resize(Rng.Areas(i).Count + 1, 1).Copy
output.Cells(i, 1).PasteSpecial Transpose:=True
Next i
End Sub

[dataminer]

stanleydgrom, Teeroy thank you very much! Both codes work perfectly!

[stanleydgrom]

dataminer,

You are very welcome. Glad we could help.

Thanks for the feedback.

And, come back anytime.

[ADITYAKANWAR]

I have same Problem , but i have 3 column

See the Attached

[JKwan]

give this a try

Option Explicit
Sub ReorgData()
Dim a As Variant, o As Variant
Dim i As Long, ii As Long, nr As Long, nc As Long
a = Cells(1).CurrentRegion
ReDim o(1 To UBound(a, 1), 1 To Columns.Count - UBound(a, 1))
For i = 1 To UBound(a, 1)
If a(i, 1) <> "" Then
nr = nr + 1
ii = ii + 1
o(ii, 1) = a(i, 1)
o(ii, 2) = a(i, 2)
o(ii, 3) = a(i, 3) ' Add more columns here
nc = 3 ' Number of columns here
Else
nc = nc + 1
o(nr, nc) = a(i, 2)
End If
Next i
Range("D1").Resize(UBound(o, 1), UBound(o, 2)) = o
Columns.AutoFit
End Sub

[ADITYAKANWAR]

give this a try

Option Explicit
Sub ReorgData()
Dim a As Variant, o As Variant
Dim i As Long, ii As Long, nr As Long, nc As Long
a = Cells(1).CurrentRegion
ReDim o(1 To UBound(a, 1), 1 To Columns.Count - UBound(a, 1))
For i = 1 To UBound(a, 1)
If a(i, 1) <> "" Then
nr = nr + 1
ii = ii + 1
o(ii, 1) = a(i, 1)
o(ii, 2) = a(i, 2)
o(ii, 3) = a(i, 3) ' Add more columns here
nc = 3 ' Number of columns here
Else
nc = nc + 1
o(nr, nc) = a(i, 2)
End If
Next i
Range("D1").Resize(UBound(o, 1), UBound(o, 2)) = o
Columns.AutoFit
End Sub



Thanks for the reply

I am getting error message "out of memory"

Is it possible to get the outcome in sheet2

[JKwan]

just change to:

Sheet2.Range("D1").Resize(UBound(o, 1), UBound(o, 2)) = o

[ADITYAKANWAR]

Again i am getting error msg out of memory

I column A i have 506 Dates and in column B i have 3653 Data and in column C has 506 Amount

I am using 2010

[JKwan]

Well, maybe you are running low (or out of) on memory, due to the size of your data. As a quick fix, chop it up and reassemble