Help needed for transfering data from rows to columns

[Svrleprle]

Hi,

I was wondering can someone help me, i have a sheet with over 100K rows and what i need is to transfer the data from rows to columns, Tried already with index & match but when i drag and drop my excel is not working anymore. Can someone help me to create a macro code for this? On the left side is original version and on right is what i need

Name	Question	Answer				email	Country	Phone
Andrea	email	test@test.com			Andrea	test@test.com	US	/
Andrea	Country	US			Sara	test@test.com	US	/
Andrea	Phone	/			Maria	test@test.com	US	/
Andrea	Skype	/
Sara	email	test@test.com
Sara	Country	US
Sara	Phone	/
Sara	Skype	/
Maria	email	test@test.com
Maria	Country	US
Maria	Phone	/
Maria	Skype	/

<colgroup><col span="2"><col><col span="3"><col><col span="2"></colgroup><tbody>
</tbody>

Pleaseee heeeelp

 

[cooper645]

hi, welcome to the forum.

Try the code below, I assumed you forgot to add the Skype info in your transposed example? (I have accounted fr it in the code)

Amend the red highlighted piece of code to the sheet name that your data set is stored in.

Option Explicit

Sub Transpose()


Dim i As Long, j As Long, c As Range, LastRow As Long, data As Worksheet


Application.ScreenUpdating = False 'turn off screen updating


Set data = Sheets("[COLOR=#ff0000]Sheet1[/COLOR]") 'change Sheet1 for the sheet name the data is on
LastRow = Cells(Rows.Count, "A").End(xlUp).Row 'count number of rows in data set


Application.DisplayAlerts = False 'stop alert about deleting transpose sheet
On Error Resume Next 'stop excel kicking off it Transposed doesn't exist
Sheets("Transposed").Delete 'if it does then delete it
Application.DisplayAlerts = True 'turn alerts back on


Sheets.Add after:=ActiveSheet 'add a new sheet
ActiveSheet.Name = "Transposed" 'name the new Sheet Transposed
Range("A1:E1").Value = Array("Name", "Email", "Country", "Phone", "Skype") 'Add headers


'loop through the entire data set
j = 2
For i = 2 To LastRow '
Cells(i, 1).Value = data.Cells(j, 1)
Cells(i, 2).Value = data.Cells(j, 3)
Cells(i, 3).Value = data.Cells(j + 1, 3)
Cells(i, 4).Value = data.Cells(j + 2, 3)
Cells(i, 5).Value = data.Cells(j + 3, 3)
j = j + 4
Next i


Range("A1:E1").Font.Bold = True 'bold the header
Columns("A:E").EntireColumn.AutoFit 'autofit the columns on transposed


Application.ScreenUpdating = True 'turn on screen updating
End Sub

 

[Fluff]

Another option

Sub CopyTrans()
   Dim Cnt As Long
   For Cnt = 2 To Range("A" & Rows.Count).End(xlUp).Row Step 4
      With Range("F" & Rows.Count).End(xlUp)
         .Offset(1).Value = Range("A" & Cnt).Value
         .Offset(1, 1).Resize(, 4).Value = Application.Transpose(Range("C" & Cnt).Resize(4))
      End With
   Next Cnt
End Sub

This will put the data in col F on the same sheet, but that can easily be changed.

 

[cooper645]

Another option

Sub CopyTrans()
   Dim Cnt As Long
   For Cnt = 2 To Range("A" & Rows.Count).End(xlUp).Row Step 4
      With Range("F" & Rows.Count).End(xlUp)
         .Offset(1).Value = Range("A" & Cnt).Value
         .Offset(1, 1).Resize(, 4).Value = Application.Transpose(Range("C" & Cnt).Resize(4))
      End With
   Next Cnt
End Sub

This will put the data in col F on the same sheet, but that can easily be changed.

Fluff, My mind is blown. so much more elegant.

 

[Svrleprle]

Fluff, My mind is blown. so much more elegant.

Thank you so so so much for the code, i am trying but when i hit run, excel is not responding - it freezes (the same thing with formula), any idea why this is happening? Also wanted to ask will the code work if column ''question'' has different values - not in this exact order?

 

[Svrleprle]

like this (someone will have mobile, someone will not but each category from this column should also be on the right ) pffff hope it makes sense :

Name	Question	Answer				email	Country	Phone
Andrea	email	test@test.com			Andrea	test@test.com	US	/
Andrea	Country	US			Sara	test@test.com	US	/
Andrea	Phone	/			Maria	test@test.com	US	/
Andrea	Mobile	/
Sara	email	test@test.com
Sara	Country	US
Sara	Phone	/
Sara	Skype	/
Maria	email	test@test.com
Maria	Country	US
Maria	Phone	/
Maria	Mobile	/

<tbody>
</tbody>

 

[Fluff]

Try this

Sub CopyTrans()
   Dim Rng As Range
   Dim Cl As Range
   Dim Hdr As Variant
   Dim Col As Variant
   
   Hdr = Array("Name", "email", "Country", "Phone", "Mobile", "Skype")
   Range("F1:K1").Value = Hdr
   Range("B:B").Replace "email", "=X", xlWhole, , False, , False, False
   For Each Rng In Range("B2", Range("B" & Rows.Count).End(xlUp)).SpecialCells(xlConstants).Areas
      With Range("F" & Rows.Count).End(xlUp)
         .Offset(1).Value = Rng.Offset(-1, -1).Resize(1, 1).Value
         .Offset(1, 1).Value = Rng.Offset(-1, 1).Resize(1, 1).Value
         For Each Cl In Rng
            Col = Application.Match(Cl.Value, Hdr, 0)
            Cl.Offset(, 1).Copy .Offset(1, Col - 1)
         Next Cl
      End With
   Next Rng
   Range("B:B").Replace "=X", "email", xlWhole, , False, , False, False

End Sub

 

[cooper645]

Thank you so so so much for the code, i am trying but when i hit run, excel is not responding - it freezes (the same thing with formula), any idea why this is happening? Also wanted to ask will the code work if column ''question'' has different values - not in this exact order?

I timed my code over 10,000 rows of data, it ran in 4 seconds, fluffs 1st code in 1.5 seconds. Fluffs second code locked up excel.

Tried all three over 160,000 rows of data, and all of them froze up.

Sheer amount of data plus lack of computing power maybe the issue?

 

[Svrleprle]

Hi again,

Thank you both for help, i am still dealing with this

The code Fluff sent works perfectly. Thanks a million!!!

I do have one more question (i tried to figure out it by myself but i am still a beginner so without success )

In column B i do have over 100 different values (not only email country phone mobile & skype)- is there a way to apply this somehow in code avoiding naming every single one? I have to admit that i tried to add values manually but it doesn't allow me when i reach 15

So instead [FONT=&quot]Hdr = Array("Name", "email", "Country", "Phone", "Mobile", "Skype") [/FONT]something to make my life easer i am begging you


Sub CopyTrans()
Dim Rng As Range
Dim Cl As Range
Dim Hdr As Variant
Dim Col As Variant
​
[FONT=&quot] Hdr = Array("Name", "email", "Country", "Phone", "Mobile", "Skype")
[/FONT] Range("F1:K1").Value = Hdr
Range("B:B").Replace "email", "=X", xlWhole, , False, , False, False
For Each Rng In Range("B2", Range("B" & Rows.Count).End(xlUp)).SpecialCells(xlConstants).Areas
With Range("F" & Rows.Count).End(xlUp)
.Offset(1).Value = Rng.Offset(-1, -1).Resize(1, 1).Value
.Offset(1, 1).Value = Rng.Offset(-1, 1).Resize(1, 1).Value
For Each Cl In Rng
Col = Application.Match(Cl.Value, Hdr, 0)
Cl.Offset(, 1).Copy .Offset(1, Col - 1)
Next Cl
End With
Next Rng
Range("B:B").Replace "=X", "email", xlWhole, , False, , False, False

End Sub

 

[cooper645]

Responding on the phone so no way to test this, however maybe try changing

[COLOR=#333333]Hdr = Array("Name", "email", "Country", "Phone", "Mobile", "Skype")
[/COLOR][COLOR=#333333]Range("F1:K1").Value = Hdr[/COLOR]

to

[COLOR=#333333]Hdr = Range("B2:B102”).value
[/COLOR][COLOR=#333333]Range("F1:DB1").Value = Hdr[/COLOR]

this assumes that you are collecting 100 pieces of information. Fingers crossed it works, but as I say, I cannot test it and maybe fluff will see the thread brought back to life and chime in.