excel vba : How to move data from rows to column

[huiyin9218]

Hi,

I have a groups of data arranged in rows, how do I write the code if I would like to arranged the groups of data in column?

AB	125	SW_85
AB	542	EEG
AB	885	FE
AB	659	DW_12
CD	123	FDC
CD	485	FERF
CD	258	GH_D

<tbody>
</tbody>

Table above is my sample table. Column A is the components name, column B and C is the data collected. I would like data to be arranged as the table below. The name of the component is on top and data arrange at the rows below. The next component and its data will be arrange at the next column.

AB			CD
125	SW_85		123	FDC
542	EEG		485	FERF
885	FE		258	GH_D
659	DW_12

<tbody>
</tbody>

Hope you guys can help me.

 

[MickG]

Try this for results on sheet2.

[COLOR="Navy"]Sub[/COLOR] MG17Aug44
[COLOR="Navy"]Dim[/COLOR] Ray [COLOR="Navy"]As[/COLOR] Variant, n [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] oMax [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] nRay() [COLOR="Navy"]As[/COLOR] Variant
[COLOR="Navy"]Dim[/COLOR] Rw [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] c [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long,[/COLOR] Num [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long[/COLOR]
[COLOR="Navy"]Dim[/COLOR] K [COLOR="Navy"]As[/COLOR] Variant, P [COLOR="Navy"]As[/COLOR] Variant
Ray = ActiveSheet.Cells(1).CurrentRegion
[COLOR="Navy"]With[/COLOR] CreateObject("scripting.dictionary")
.CompareMode = vbTextCompare
[COLOR="Navy"]For[/COLOR] n = 1 To UBound(Ray, 1)
    [COLOR="Navy"]If[/COLOR] Not .Exists(Ray(n, 1)) [COLOR="Navy"]Then[/COLOR]
        .Add Ray(n, 1), New Collection
        .Item(Ray(n, 1)).Add n
    [COLOR="Navy"]Else[/COLOR]
        .Item(Ray(n, 1)).Add n
        [COLOR="Navy"]End[/COLOR] If
[COLOR="Navy"]Next[/COLOR]
ReDim Preserve nRay(1 To UBound(Ray), 1 To .Count * 3)
[COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] K [COLOR="Navy"]In[/COLOR] .keys
    Rw = 1
    c = c + IIf(c = 0, 1, 3)
    nRay(Rw, c) = K
        [COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] P [COLOR="Navy"]In[/COLOR] .Item(K)
            Rw = Rw + 1
            nRay(Rw, c) = Ray(P, 2)
            nRay(Rw, c + 1) = Ray(P, 3)
            [COLOR="Navy"]If[/COLOR] Rw > oMax [COLOR="Navy"]Then[/COLOR] oMax = Rw
        [COLOR="Navy"]Next[/COLOR] P
[COLOR="Navy"]Next[/COLOR] K
Num = .Count
[COLOR="Navy"]End[/COLOR] With
[COLOR="Navy"]With[/COLOR] Sheets("Sheet2").Range("A1").Resize(oMax, Num * 3)
   .Value = nRay
   .Borders.Weight = 2
  .Columns.AutoFit
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]With[/COLOR]
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]Sub[/COLOR]

Regards Mick

 

[Yongle]

Another way
- amend RawData to the name of the sheet containing data
- new sheet added with data tabulated
- the code below assumes headers are currently in A1:A3 with data starting in row 2
- amend A2 to the first cell containing data (not the headrer row)

Option Explicit

Sub TabulateByName()
    Application.ScreenUpdating = False
    Dim ws1 As Worksheet, ws2 As Worksheet, rng As Range, cel As Range
    Dim c As Long
    Dim coll As New Collection, component As Variant
    
    Set ws1 = Sheets("[COLOR=#ff0000]RawData[/COLOR]")
    Set ws2 = Worksheets.Add(after:=ws1)
    Set rng = ws1.Range("[COLOR=#ff0000]A2[/COLOR]", ws1.Range("A" & Rows.Count).End(xlUp))
'create unique list of components
    For Each cel In rng
        On Error Resume Next
        coll.Add cel, cel
        On Error GoTo 0
    Next
'filter data based on each component in turn
    c = 1
    For Each component In coll
        With rng.CurrentRegion
            .AutoFilter
            .AutoFilter Field:=1, Criteria1:=component
        End With
'paste data to worksheet
        ws2.Cells(1, c) = component
        With ws2.Cells(2, c)
            rng.Offset(, 1).Resize(, 2).SpecialCells(xlCellTypeVisible).Copy
            .PasteSpecial xlPasteColumnWidths
            .PasteSpecial (xlAll)
        End With
        c = c + 3
    Next
    ws2.

Activate: ws2.Cells(1).Select
End Sub

 

[Yongle]

I made a mess of that post.. .
Let's try again

Another way
- amend RawData to the name of the sheet containing data
- new sheet added with data tabulated
- the code below assumes headers are currently in A1:C1 with data starting in row 2
- amend A2 to the first cell containing data (not the headrer row)

Option Explicit

Sub TabulateByName()
    Application.ScreenUpdating = False
    Dim ws1 As Worksheet, ws2 As Worksheet, rng As Range, cel As Range
    Dim c As Long
    Dim coll As New Collection, component As Variant
    
    Set ws1 = Sheets("[COLOR=#ff0000]RawData[/COLOR]")
    Set ws2 = Worksheets.Add(after:=ws1)
    Set rng = ws1.Range("[COLOR=#ff0000]A2[/COLOR]", ws1.Range("A" & Rows.Count).End(xlUp))
'create unique list of components
    For Each cel In rng
        On Error Resume Next
        coll.Add cel, cel
        On Error GoTo 0
    Next
'filter data based on each component in turn
    c = 1
    For Each component In coll
        With rng.CurrentRegion
            .AutoFilter
            .AutoFilter Field:=1, Criteria1:=component
        End With
'paste data to workshet
        ws2.Cells(1, c) = component
        With ws2.Cells(2, c)
            rng.Offset(, 1).Resize(, 2).SpecialCells(xlCellTypeVisible).Copy
            .PasteSpecial xlPasteColumnWidths
            .PasteSpecial (xlAll)
        End With
        c = c + 3
    Next
    ws2.Activate:   ws2.Cells(1).Select
End Sub

 

[huiyin9218]

Thank you so much MickG and Yongle! Both of your code works perfectly

 

[Yongle]

Thank you for the feedback

 

[Peter_SSs]

Yet another approach. I have also assumed ..
- a header row in the original data (on sheet 'RawData')
- Sheet 'Results' exists and is empty awaiting the newly arranged data
- the values in column B of 'RawData' are not the result of formulas

Sub Rearrange()
  Dim rA As Range
  Dim nc As Long
  
  With Sheets("RawData")
    .UsedRange.Subtotal GroupBy:=1, Function:=xlCount, TotalList:=Array(2)
    nc = 1
    For Each rA In .Range("B2", .Range("B" & .Rows.Count).End(xlUp)).SpecialCells(xlConstants).Areas
      With Sheets("Results").Cells(1, nc)
        .Value = rA.Cells(1, 0).Value
        .Offset(1).Resize(rA.Rows.Count, 2).Value = rA.Resize(, 2).Value
      End With
      nc = nc + 3
    Next rA
    .UsedRange.RemoveSubtotal
  End With
End Sub