Help needed for transfering data from rows to columns

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 :)
 
How about
Code:
Sub CopyTrans()
   Dim Rng As Range, Cl As Range
   Dim Hdr As Variant, Col As Variant
   Dim i As Long
   Dim Dic As Object
   
   Application.ScreenUpdating = False
   Hdr = Range("B2", Range("B" & Rows.Count).End(xlUp)).Value2
   Set Dic = CreateObject("scripting.dictionary")
   For i = 1 To UBound(Hdr)
      If Not Dic.Exists(Hdr(i, 1)) Then Dic.Add Hdr(i, 1), i
   Next i
   Range("G1").Resize(, Dic.Count).Value = Dic.Keys
   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 = Dic(Cl.Value)
            Cl.Offset(, 1).Copy .Offset(1, Col)
         Next Cl
      End With
   Next Rng
   Range("B:B").Replace "=X", "email", xlWhole, , False, , False, False

End Sub
 
Upvote 0

Excel Facts

Which lookup functions find a value equal or greater than the lookup value?
MATCH uses -1 to find larger value (lookup table must be sorted ZA). XLOOKUP uses 1 to find values greater and does not need to be sorted.
hI there,

thank you so much for looking into this

I tryied this one:

Sub CopyTrans()
Dim Rng As Range
Dim Cl As Range
Dim Hdr As Variant
Dim Col As Variant


Hdr = Range("B2:B102”).value
Range("F1:DB1").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


It doesnt work :( yeah i do have 100 different categories in more than 10 000 rows :(

Have no clue how to sort it out :(
 
Upvote 0
How about
Code:
Sub CopyTrans()
   Dim Rng As Range, Cl As Range
   Dim Hdr As Variant, Col As Variant
   Dim i As Long
   Dim Dic As Object
   
   Application.ScreenUpdating = False
   Hdr = Range("B2", Range("B" & Rows.Count).End(xlUp)).Value2
   Set Dic = CreateObject("scripting.dictionary")
   For i = 1 To UBound(Hdr)
      If Not Dic.Exists(Hdr(i, 1)) Then Dic.Add Hdr(i, 1), i
   Next i
   Range("G1").Resize(, Dic.Count).Value = Dic.Keys
   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 = Dic(Cl.Value)
            Cl.Offset(, 1).Copy .Offset(1, Col)
         Next Cl
      End With
   Next Rng
   Range("B:B").Replace "=X", "email", xlWhole, , False, , False, False

End Sub





IT WOOOOOOOOOORKS!!!!!!!!!!!!!!! thanks a million!!!!!!!!!!!!

Thank you so much guys :) :)
 
Upvote 0
Glad to help & thanks for the feedback
 
Upvote 0

Forum statistics

Threads
1,223,885
Messages
6,175,184
Members
452,615
Latest member
bogeys2birdies

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