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

[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

 

[Fluff]

How about

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

 

[Svrleprle]

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

 

[Svrleprle]

How about

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

 

[Fluff]

Glad to help & thanks for the feedback