Help needed for transfering data from rows to columns

S

Svrleprle

New Member
Joined
Feb 20, 2018
Messages
6
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

[TABLE="width: 646"]
<colgroup><col span="2"><col><col span="3"><col><col span="2"></colgroup><tbody>[TR]
[TD]Name[/TD]
[TD]Question[/TD]
[TD]Answer[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD]email[/TD]
[TD]Country [/TD]
[TD]Phone[/TD]
[/TR]
[TR]
[TD]Andrea[/TD]
[TD]email[/TD]
[TD]test@test.com[/TD]
[TD][/TD]
[TD][/TD]
[TD]Andrea[/TD]
[TD]test@test.com[/TD]
[TD]US[/TD]
[TD]/[/TD]
[/TR]
[TR]
[TD]Andrea[/TD]
[TD]Country [/TD]
[TD]US[/TD]
[TD][/TD]
[TD][/TD]
[TD]Sara[/TD]
[TD]test@test.com[/TD]
[TD]US[/TD]
[TD]/[/TD]
[/TR]
[TR]
[TD]Andrea[/TD]
[TD]Phone[/TD]
[TD]/[/TD]
[TD][/TD]
[TD][/TD]
[TD]Maria[/TD]
[TD]test@test.com[/TD]
[TD]US[/TD]
[TD]/[/TD]
[/TR]
[TR]
[TD]Andrea[/TD]
[TD]Skype[/TD]
[TD]/[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]Sara[/TD]
[TD]email[/TD]
[TD]test@test.com[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]Sara[/TD]
[TD]Country [/TD]
[TD]US[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]Sara[/TD]
[TD]Phone[/TD]
[TD]/[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]Sara[/TD]
[TD]Skype[/TD]
[TD]/[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]Maria[/TD]
[TD]email[/TD]
[TD]test@test.com[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]Maria[/TD]
[TD]Country [/TD]
[TD]US[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]Maria[/TD]
[TD]Phone[/TD]
[TD]/[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]Maria[/TD]
[TD]Skype[/TD]
[TD]/[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
</tbody>[/TABLE]


Pleaseee heeeelp :)
 

Excel Facts

Ambidextrous Undo
Undo last command with Ctrl+Z or Alt+Backspace. If you use the Undo icon in the QAT, open the drop-down arrow to undo up to 100 steps.
Sort by date Sort by votes
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.

Code: 
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
 
Upvote 0
Another option
Code: 
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.
 
Upvote 0
Fluff said:
Another option
Code: 
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.
Click to expand...

Fluff, My mind is blown. so much more elegant.
 
Upvote 0
cooper645 said:
Fluff, My mind is blown. so much more elegant.
Click to expand...


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?
 
Upvote 0
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 :

[TABLE="class: cms_table, width: 646"]
<tbody>[TR]
[/TR]
[TR]
[TD]Name[/TD]
[TD]Question[/TD]
[TD]Answer[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD]email[/TD]
[TD]Country[/TD]
[TD]Phone[/TD]
[/TR]
[TR]
[TD]Andrea[/TD]
[TD]email[/TD]
[TD]test@test.com[/TD]
[TD][/TD]
[TD][/TD]
[TD]Andrea[/TD]
[TD]test@test.com[/TD]
[TD]US[/TD]
[TD]/[/TD]
[/TR]
[TR]
[TD]Andrea[/TD]
[TD]Country[/TD]
[TD]US[/TD]
[TD][/TD]
[TD][/TD]
[TD]Sara[/TD]
[TD]test@test.com[/TD]
[TD]US[/TD]
[TD]/[/TD]
[/TR]
[TR]
[TD]Andrea[/TD]
[TD]Phone[/TD]
[TD]/[/TD]
[TD][/TD]
[TD][/TD]
[TD]Maria[/TD]
[TD]test@test.com[/TD]
[TD]US[/TD]
[TD]/[/TD]
[/TR]
[TR]
[TD]Andrea[/TD]
[TD]Mobile[/TD]
[TD]/[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]Sara[/TD]
[TD]email[/TD]
[TD]test@test.com[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]Sara[/TD]
[TD]Country[/TD]
[TD]US[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]Sara[/TD]
[TD]Phone[/TD]
[TD]/[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]Sara[/TD]
[TD]Skype[/TD]
[TD]/[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]Maria[/TD]
[TD]email[/TD]
[TD]test@test.com[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]Maria[/TD]
[TD]Country[/TD]
[TD]US[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]Maria[/TD]
[TD]Phone[/TD]
[TD]/[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]Maria[/TD]
[TD]Mobile[/TD]
[TD]/[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
</tbody>[/TABLE]
 
Upvote 0
Try this
Code: 
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
 
Upvote 0
Svrleprle said:
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?
Click to expand...

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?
 
Upvote 0
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 :confused: )

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
 
Upvote 0
Responding on the phone so no way to test this, however maybe try changing

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

to

Code: 
[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.
 
Upvote 0
You must log in or register to reply here.

Similar threads

C
  • Question Question
Macro Help - Transposing Some Data from Columns to Rows, Accounting for Duplicate Data
Replies
1
Views
116
Kaper
Kaper
F
  • Question Question
Need help transferring rows of data in one sheet to another when checkbox checked
2
Replies
14
Views
1K
mumps
mumps
M
  • Solved
VBA Help - Duplicate & Unwanted Data Removal
Replies
6
Views
928
MoonDancer
M
C
  • Solved
Extracting data with VBA macro button from files in designated folder
2 3
Replies
20
Views
844
Micron
M
T
  • Question Question
Excel online Script to move data from one sheet to another (NOT VBA)
Replies
1
Views
380
tonywatsonhelp
T

Forum statistics

Threads
1,223,880
Messages
6,175,153
Members
452,615
Latest member
bogeys2birdies

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top