Moving from Sequental Rows to Columns?

[petersw]

Hi,

Currently have data set up in multiple rows, as follows:

[TABLE="width: 500"]
<tbody>[TR]
[TD]Subject ID
[/TD]
[TD]Lot Numbers
[/TD]
[/TR]
[TR]
[TD]10001
[/TD]
[TD]9001, 9002
[/TD]
[/TR]
[TR]
[TD]10001
[/TD]
[TD]9345, 9100
[/TD]
[/TR]
[TR]
[TD]10002
[/TD]
[TD]9004, 9005
[/TD]
[/TR]
[TR]
[TD]10002
[/TD]
[TD]9045, 9099
[/TD]
[/TR]
</tbody>[/TABLE]

and would like to have it as

[TABLE="width: 500"]
<tbody>[TR]
[TD]Subject ID
[/TD]
[TD]Lot Numbers - Grp 1
[/TD]
[TD]Lot Number - Grp 2
[/TD]
[/TR]
[TR]
[TD]10001
[/TD]
[TD]9001, 9002
[/TD]
[TD]9345, 9100
[/TD]
[/TR]
[TR]
[TD]10002
[/TD]
[TD]9004, 9005
[/TD]
[TD]9045, 9099
[/TD]
[/TR]
</tbody>[/TABLE]

I just know this will be easy for someone out there, and thanks in advance!

 

[lrobbo314]

This can be done with PowerQuery.

let
    Source = Excel.CurrentWorkbook(){[Name="Table1"]}[Content],
    Group = Table.Group(Source, {"Subject ID"}, {{"Count", each _, type table}}),
    Cutom = Table.AddColumn(Group, "Custom", each Table.Column([Count],"Lot Numbers")),
    Extract = Table.TransformColumns(Cutom, {"Custom", each Text.Combine(List.Transform(_, Text.From), "@"), type text}),
    Split = Table.SplitColumn(Extract, "Custom", Splitter.SplitTextByDelimiter("@", QuoteStyle.Csv), {"Lot Numbers - Grp 1", "Lot Numbers - Grp 2"}),
    Remove = Table.RemoveColumns(Split,{"Count"})
in
    Remove

 

[sandy666]

a bit different

[SIZE=1]let
    Source = Excel.CurrentWorkbook(){[Name="Table1"]}[Content],
    Group = Table.Group(Source, {"Subject ID"}, {{"Count", each _, type table}}),
    List = Table.AddColumn(Group, "Lot Numbers Grp", each Table.Column([Count],"Lot Numbers")),
    Extract = Table.TransformColumns(List, {"Lot Numbers Grp", each Text.Combine(List.Transform(_, Text.From), "="), type text}),
    Split = Table.SplitColumn(Extract, "Lot Numbers Grp", Splitter.SplitTextByDelimiter("=", QuoteStyle.Csv), {"Lot Numbers Grp.1", "Lot Numbers Grp.2"})
in
    Split[/SIZE]

 

[lrobbo314]

I keep forgetting that you don't need to remove that unused column with the 'Table' values in them. Good call.

 

[sandy666]

and you don't need to change name of columns manually

 

[kweaver]

Since I don't know PowerQuery (yet)...I remember I had a macro that did this...I just found it.
Not sure where it came from originally.

I doctored the last few rows to meet your headings.

It works off Sheet1 with your data starting in A1 (row 1 is headers) and assume you have a sheet2 into which the result(s) are place.

Sub XTranspose()
  Dim OutSH As Worksheet
  Set OutSH = Sheets("Sheet2")
  
  Range("A:A").AdvancedFilter Action:=xlFilterCopy, copytorange:=OutSH.Range("A1"), Unique:=xlYes
  
  'determine last column based on header
  lastcol = Cells(1, Columns.Count).End(xlToLeft).Column
  
  For Each ce In Range("A2:A" & Cells(Rows.Count, 1).End(xlUp).Row)
    Set findit = OutSH.Range("A:A").Find(what:=ce.Value)
    
    For i = 1 To lastcol
      OutSH.Cells(findit.Row, Columns.Count).End(xlToLeft).Offset(0, 1).Value = Cells(ce.Row, i).Value
    Next i
  Next ce
  With OutSH
    .Range(.Range("A2"), .Range("A2").End(xlDown)).Delete shift:=xlToLeft
  End With
  Sheets("Sheet2").Columns("C").Delete
  Sheets("Sheet2").Range("A1") = "Subject ID"
  Sheets("Sheet2").Range("B1") = "Group 1"
  Sheets("Sheet2").Range("C1") = "Group 2"
  
End Sub

 

[petersw]

You are all incredible. Thank you!!!

 

[sandy666]

You are welcome

 

[lrobbo314]

A different approach to the VBA solution. This assumes that your original data is in columns A:B, and the output will be in columns D:F.

Sub GroupIDs()
Application.ScreenUpdating = False


Dim AR() As Variant:    AR = Range("A1:B" & Range("A" & Rows.Count).End(xlUp).Row).Value
Dim SD As Object:       Set SD = CreateObject("Scripting.Dictionary")


For i = LBound(AR) To UBound(AR)
    If Not SD.exists(AR(i, 1)) Then
        SD.Add AR(i, 1), AR(i, 2)
    Else
        SD(AR(i, 1)) = SD(AR(i, 1)) & "@" & AR(i, 2)
    End If
Next i


Range("D1").Resize(SD.Count, 1).Value = Application.Transpose(SD.keys)
Range("E1").Resize(SD.Count, 1).Value = Application.Transpose(SD.items)
Range("E2:E" & Range("E" & Rows.Count).End(xlUp).Row).TextToColumns DataType:=xlDelimited, OtherChar:="@"
Range("E1:F1").Value = Array("Lot Numbers - Grp 1", "Lot Numbers - Grp 2")


Application.ScreenUpdating = False
End Sub