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?

[TABLE="class: grid, width: 300"]
<tbody>[TR]
[TD]AB[/TD]
[TD]125[/TD]
[TD]SW_85[/TD]
[/TR]
[TR]
[TD]AB[/TD]
[TD]542[/TD]
[TD]EEG[/TD]
[/TR]
[TR]
[TD]AB[/TD]
[TD]885[/TD]
[TD]FE[/TD]
[/TR]
[TR]
[TD]AB[/TD]
[TD]659[/TD]
[TD]DW_12[/TD]
[/TR]
[TR]
[TD]CD[/TD]
[TD]123[/TD]
[TD]FDC[/TD]
[/TR]
[TR]
[TD]CD[/TD]
[TD]485[/TD]
[TD]FERF[/TD]
[/TR]
[TR]
[TD]CD[/TD]
[TD]258[/TD]
[TD]GH_D[/TD]
[/TR]
</tbody>[/TABLE]

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.

[TABLE="class: grid, width: 500"]
<tbody>[TR]
[TD]AB[/TD]
[TD][/TD]
[TD][/TD]
[TD]CD[/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]125[/TD]
[TD]SW_85[/TD]
[TD][/TD]
[TD]123[/TD]
[TD]FDC[/TD]
[TD][/TD]
[/TR]
[TR]
[TD]542[/TD]
[TD]EEG[/TD]
[TD][/TD]
[TD]485[/TD]
[TD]FERF[/TD]
[TD][/TD]
[/TR]
[TR]
[TD]885[/TD]
[TD]FE[/TD]
[TD][/TD]
[TD]258[/TD]
[TD]GH_D[/TD]
[TD][/TD]
[/TR]
[TR]
[TD]659[/TD]
[TD]DW_12[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
</tbody>[/TABLE]

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