Rows to Columns

[Gerrit.B]

In my Excel sheet I have multiple rows with data from the same customer. (orange)
I need to transpose this data to one row per customer, where all invoice numbers are in 1 line as shown in image (green part)

How can this be done?

 

[farmerscott]

for what it is worth....... a youtube video on a formula solution to the problem.

 

[Gerrit.B]

In that case the modification is fairly simple. Try this version.

Sub Rearrange_v2()
  Dim a As Variant, b As Variant
  Dim i As Long, r As Long, c As Long, MaxCols As Long
 
  a = Range("A1", Range("B" & Rows.Count).End(xlUp)).Value
  ReDim b(1 To UBound(a), 1 To 2)
  For i = 2 To UBound(a)
    If a(i, 1) <> a(i - 1, 1) Then
      r = r + 1
      b(r, 1) = a(i, 1)
      b(r, 2) = a(i, 2)
      c = 2
    Else
      If a(i, 2) <> a(i - 1, 2) Then
        c = c + 1
        If c > MaxCols Then
          MaxCols = c
          ReDim Preserve b(1 To UBound(b), 1 To MaxCols)
        End If
        b(r, c) = a(i, 2)
      End If
    End If
  Next i
  With Range("E1").Resize(, MaxCols)
    .Formula = "=""Invoice ""&COLUMNS($E1:E1)-1"
    .Value = .Value
    .Cells(1).ClearContents
    .Offset(1).Resize(r).Value = b
    .EntireColumn.AutoFit
  End With
End Sub

Gerrit.B 2020-07-14 1.xlsm
	A	B	C	D	E	F	G	H
1	Customer	Invoice				Invoice 1	Invoice 2	Invoice 3
2	Customer 1	55			Customer 1	55
3	Customer 2	56			Customer 2	56	57	58
4	Customer 2	57			Customer 3	59
5	Customer 2	57			Customer 4	60	61
6	Customer 2	58
7	Customer 3	59
8	Customer 4	60
9	Customer 4	61
Sheet1

Sub Rearrange2() 'Email
 Dim a As Variant, b As Variant, x As Variant
  Dim i As Long, r As Long, c As Long, MaxCols As Long
    ThisWorkbook.Sheets("RemindersByExcel1").Activate
  a = Range("A1", Range("G" & Rows.Count).End(xlUp)).Value
  x = 3 'change number to get data from correct column.
  ReDim b(1 To UBound(a), 1 To 2)
  For i = 2 To UBound(a)
    If a(i, 1) <> a(i - 1, 1) Then
      r = r + 1
      b(r, 1) = a(i, 1)
      b(r, 2) = a(i, x)
      c = 2
    Else
      If a(i, x) <> a(i - 1, x) Then
        c = c + 1
        If c > MaxCols Then
          MaxCols = c
          ReDim Preserve b(1 To UBound(b), 1 To MaxCols)
        End If
        b(r, c) = a(i, x)
      End If
    End If
  Next i
  ThisWorkbook.Sheets("Mail").Activate
  With Range("A11").Resize(, MaxCols)
    .Formula = "=""Email ""&COLUMNS($E1:E1)-1"
    .Value = .Value
    .Cells(1).ClearContents
    .Offset(1).Resize(r).Value = b
    .EntireColumn.AutoFit
  End With
End Sub

I change your code a little to rearrange all values.
Then I noticed I have the data also as you mentioned in your first table.

 

[sandy666]

just for fun as alternative

Customer	Invoice		Customer	Invoice.1	Invoice.2	Invoice.3	Invoice.4	Invoice.5
Customer 1	55		Customer 1	55
Customer 2	56		Customer 2	56	57	58
Customer 2	57		Customer 3	59
Customer 2	58		Customer 4	60	61
Customer 3	59		Customer 5	100	120	130	140	150
Customer 4	60
Customer 4	60
Customer 4	61
Customer 5	100
Customer 5	120
Customer 5	130
Customer 5	140
Customer 5	150
Customer 5	100
Customer 1	55
Customer 2	57

let
    Source = Excel.CurrentWorkbook(){[Name="Table1"]}[Content],
    Group = Table.Group(Source, {"Customer"}, {{"Count", each _, type table}}),
    List = Table.AddColumn(Group, "Invoice", each List.Distinct([Count][Invoice])),
    Extract = Table.TransformColumns(List, {"Invoice", each Text.Combine(List.Transform(_, Text.From), ","), type text}),
    SortLen = Table.Sort(Table.AddColumn(Extract, "Length", each Text.Length([Invoice]), Int64.Type),{{"Length", Order.Descending}}),
    Split = Table.SplitColumn(SortLen, "Invoice", Splitter.SplitTextByAnyDelimiter({","}, QuoteStyle.Csv)),
    Sort = Table.Sort(Table.RemoveColumns(Split,{"Count", "Length"}),{{"Customer", Order.Ascending}})
in
    Sort

 

[Peter_SSs]

I change your code a little to rearrange all values.
Then I noticed I have the data also as you mentioned in your first table.

So, are you all sorted now?

 

[Gerrit.B]

So, are you all sorted now?

Most of the columns are ok, but only where te values are as in your fist table are mention twice.
In te columns with it's the same customer, same invoice, but with 2 rows as there are 2 contacts.
The output will be Contact1, Contact2, Contact1, Contact2.

 

[Peter_SSs]

Most of the columns are ok, but only where te values are as in your fist table are mention twice.
In te columns with it's the same customer, same invoice, but with 2 rows as there are 2 contacts.
The output will be Contact1, Contact2, Contact1, Contact2.

I am not familiar with your data so that is pretty much meaningless to me. Up until now we have had 'Customer' and 'Invoice'. Now you are referring to 'Contact's as well.
Can you post a small set of sample dummy data and the expected results with XL2BB and explain clearly in relation to that new sample data?

 

[Gerrit.B]

Book1
	A	B	C	D	E	F	G	H	I	J	K
1	Customer	Invoice	Contact			Customer	Contact1	Contact2	Contact3	Contact4	Contact5
2	Customer 1	55	1			Customer 1	1
3	Customer 2	56	2			Customer 2	2	3	2	3
4	Customer 2	56	3			Customer 4	4
5	Customer 2	57	2
6	Customer 2	57	3
7	Customer 4	60	4
Sheet1

See results above.

 

[DanteAmor]

Hi @Gerrit.B,
That represents a great change. If you no longer need the invoice in the output, then try the following macro.
The data in Sheet1 the results in the sheet "Mail"

Sub RowsToColumns()
  Dim a As Variant, dic1 As Object, i As Long
  
  Application.DisplayAlerts = False
  Set dic1 = CreateObject("Scripting.Dictionary")
  a = Sheets("Sheet1").Range("A2:G" & Sheets("Sheet1").Range("A" & Rows.Count).End(3).Row).Value
  For i = 1 To UBound(a, 1)
    dic1(a(i, 1)) = dic1(a(i, 1)) & a(i, 3) & "|"
  Next
  With Sheets("Mail").Range("A11")
    .Resize(dic1.Count, 2).Value = Application.Transpose(Array(dic1.keys, dic1.items))
    .Offset(, 1).Resize(dic1.Count).TextToColumns .Offset(, 1), xlDelimited, Other:=True, OtherChar:="|"
  End With
End Sub

 

[Gerrit.B]

Hi @Gerrit.B,
That represents a great change. If you no longer need the invoice in the output, then try the following macro.
The data in Sheet1 the results in the sheet "Mail"

Sub RowsToColumns()
  Dim a As Variant, dic1 As Object, i As Long
 
  Application.DisplayAlerts = False
  Set dic1 = CreateObject("Scripting.Dictionary")
  a = Sheets("Sheet1").Range("A2:G" & Sheets("Sheet1").Range("A" & Rows.Count).End(3).Row).Value
  For i = 1 To UBound(a, 1)
    dic1(a(i, 1)) = dic1(a(i, 1)) & a(i, 3) & "|"
  Next
  With Sheets("Mail").Range("A11")
    .Resize(dic1.Count, 2).Value = Application.Transpose(Array(dic1.keys, dic1.items))
    .Offset(, 1).Resize(dic1.Count).TextToColumns .Offset(, 1), xlDelimited, Other:=True, OtherChar:="|"
  End With
End Sub

Thanks Dante,

I prefer to use code from Peter as i have to run this code 6 times to get all the data in the correct format.
After every run I go to the next column to collect my data.

Regards,

Gerrit

 

[DanteAmor]

I prefer to use code from Peter as i have to run this code 6 times to get all the data in the correct format.
After every run I go to the next column to collect my data.

My code does what you asked for in post #28.
Did you at least try it?