Rows to Columns

Gerrit.B

Board Regular
Joined
Aug 10, 2004
Messages
234
Office Version
  1. 2019
  2. 2016
Platform
  1. Windows
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?
 

Attachments

  • 2020-07-14_095253.png
    2020-07-14_095253.png
    10.1 KB · Views: 43

Excel Facts

Excel Can Read to You
Customize Quick Access Toolbar. From All Commands, add Speak Cells or Speak Cells on Enter to QAT. Select cells. Press Speak Cells.

DanteAmor

Well-known Member
Joined
Dec 3, 2018
Messages
13,582
Office Version
  1. 2007
Platform
  1. Windows
Don't worry, we are here to help you.:giggle:
 

Peter_SSs

MrExcel MVP, Moderator
Joined
May 28, 2005
Messages
50,601
Office Version
  1. 365
Platform
  1. Windows
See results above.
OK, so now that you are looking at Contact, you are getting duplicates because the duplicate contacts for a customer are not necessarily beside each other. It is more like my second image in post #17.

Assuming your original table is composed of 'constant' values not 'formula' values then you could try something like this. This has an extra step to sort the data by customer and the column of interest (& putting the data back how it was at the end)

VBA Code:
Sub Rearrange_v3()
  Dim a As Variant, b As Variant, aOriginal As Variant
  Dim i As Long, r As Long, c As Long, MaxCols As Long
 
  With Range("A1", Range("C" & Rows.Count).End(xlUp))
    aOriginal = .Value
    .Sort Key1:=.Columns(1), Order1:=xlAscending, Key2:=.Columns(3), Order2:=xlAscending, Header:=xlYes, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
    a = .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, 3)
        c = 2
      Else
        If a(i, 3) <> a(i - 1, 3) 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, 3)
        End If
      End If
    Next i
    .Value = aOriginal
  End With
  With Range("E1").Resize(, MaxCols)
    .Formula = "=""Contact ""&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
ABCDEFG
1CustomerInvoiceContactContact 1Contact 2
2Customer 1551Customer 11
3Customer 2562Customer 223
4Customer 2563Customer 44
5Customer 2572
6Customer 2573
7Customer 4604
Sheet2
 

DanteAmor

Well-known Member
Joined
Dec 3, 2018
Messages
13,582
Office Version
  1. 2007
Platform
  1. Windows
Here is another macro with another approach for you to consider

VBA Code:
Sub RowsToColumns_1()
  Dim a As Variant, dic1 As Object, dic2 As Object
  Dim i As Long, j As Long, k As Long
  
  Application.DisplayAlerts = False
  Set dic1 = CreateObject("Scripting.Dictionary")
  Set dic2 = CreateObject("Scripting.Dictionary")
  a = Range("A2:G" & Range("A" & Rows.Count).End(3).Row).Value
  For i = 1 To UBound(a, 1)
    If Not dic1.exists(a(i, 1)) Then
      dic1(a(i, 1)) = a(i, 3)
    Else
      If Not dic2.exists(a(i, 1) & "|" & a(i, 3)) Then dic1(a(i, 1)) = dic1(a(i, 1)) & "|" & a(i, 3)
    End If
    dic2(a(i, 1) & "|" & a(i, 3)) = Empty
  Next
  With Range("E2")
    .Resize(dic1.Count, 2).Value = Application.Transpose(Array(dic1.keys, dic1.items))
    .Offset(, 1).Resize(dic1.Count).TextToColumns .Offset(, 1), xlDelimited, Other:=True, OtherChar:="|"
    .Offset(-1, 1).Value = "Contact 1"
    .Offset(-1, 1).Resize(1, Rows(.Row & ":" & .Row + dic1.Count + 1).Find("*", , xlValues, 2, 2, 2).Column - .Column).DataSeries 1, 4, 1
  End With
End Sub

Dante Amor
ABCDEFGH
1CustomerInvoiceContactContact 1Contact 2
2Customer 1551Customer 11
3Customer 2562Customer 223
4Customer 2563Customer 44
5Customer 2572
6Customer 2573
7Customer 4604
8
Sheet1
 

Peter_SSs

MrExcel MVP, Moderator
Joined
May 28, 2005
Messages
50,601
Office Version
  1. 365
Platform
  1. Windows

ADVERTISEMENT

If taking a dictionary approach, mine would be (assuming output going after a blank column)

VBA Code:
Sub Rearrange_v4()
  Dim d As Object
  Dim a As Variant
  Dim i As Long
  
  a = Range("A1", Range("C" & Rows.Count).End(xlUp)).Value
  Set d = CreateObject("Scripting.Dictionary")
  For i = 2 To UBound(a)
    If InStr(1, ";" & d(a(i, 1)), ";" & a(i, 3) & ";", 1) = 0 Then d(a(i, 1)) = d(a(i, 1)) & a(i, 3) & ";"
  Next i
  With Range("E2:F2").Resize(d.Count)
    .Value = Application.Transpose(Array(d.Keys, d.Items))
    .Columns(2).TextToColumns , xlDelimited, , , False, True, False, False, False
    .Cells(0, 2).Value = "Contact 1"
    .Cells(0, 2).AutoFill .Cells(0, 2).Resize(, .CurrentRegion.Columns.Count - 1)
  End With
End Sub
 

Gerrit.B

Board Regular
Joined
Aug 10, 2004
Messages
234
Office Version
  1. 2019
  2. 2016
Platform
  1. Windows
I will try to share with you my goal to solve.
Below you will find my data I have to convert.

MailToList - Copy.xlsm
ABCDEFG
1CompanyInvoiceEmail ContactOrder.DueDateContactPO.
2Company 111John@samplemail.com31608/07/2020John3476
3Company 212Peter@samplemail.com29920/07/2020Peter3289
4Company 212Alan@samplemail.com29920/07/2020Alan3289
5Company 315Mick@samplemail.com25105/03/2020Mick2761
6Company 416Jason@samplemail.com43806/02/2020Jason4818
7Company 416Daisy@samplemail.com43806/02/2020Daisy4818
8Company 417Jason@samplemail.com44006/02/2020Jason4840
9Company 417Daisy@samplemail.com44006/02/2020Daisy4840
10Company 518Robbert@samplemail.com42620/07/2020Robbert4686
RemindersByExcel1


Below you will find the the results I need.

MailToList - Copy.xlsm
ABCDEFGHIJKLMNOPQRSTUVWXYZAA
1CompanyContact1Contact2Contact3Contact4Contact5Email1Email2Email3Email4Email5Invoice1Invoice2Invoice3Invoice4Invoice5Order1Order2Order3Order4Order5PO1PO2PO3PO4PO5DueDate
2Company 1JohnJohn@samplemail.com11316347608/07/2020
3Company 2PeterAlanPeter@samplemail.comAlan@samplemail.com12299328920/07/2020
4Company 3MickJasonMick@samplemail.com15251276105/03/2020
5Company 4JasonDaisyJason@samplemail.comDaisy@samplemail.com16174384404818484006/02/2020
6Company 5RobbertRobbert@samplemail.com18426468620/07/2020
Mail


From here I have already have the VBA code to generate a mail for every company including all required documents.
All outputs should be maximised to 5 results, for the last column I only need for every customer the oldest date.
 

Peter_SSs

MrExcel MVP, Moderator
Joined
May 28, 2005
Messages
50,601
Office Version
  1. 365
Platform
  1. Windows

ADVERTISEMENT

Assuming ..
  • Data on 'RemindersByExcel1' is sorted by Company
  • 'Mail' sheet already has the headings in A1:AA1 and any other existing data on that sheet can be removed
.. try

VBA Code:
Option Explicit
Option Base 1

Sub Rearrange_v5()
  Dim a As Variant, b As Variant, ColOrder As Variant
  Dim i As Long, j As Long, c As Long, Col As Long, k As Long
  
  ColOrder = Array(6, 3, 2, 4, 7, 5)
  With Sheets("RemindersByExcel1")
    a = .Range("A1", .Range("G" & .Rows.Count).End(xlUp)).Value
  End With
  ReDim b(1 To UBound(a), 1 To 27)
  For i = 2 To UBound(a)
    If a(i, 1) <> a(i - 1, 1) Then
      k = k + 1
      b(k, 1) = a(i, 1)
    End If
    For c = 1 To 5
      Col = ColOrder(c)
      For j = 0 To 4
        If LCase(b(k, c * 5 - 3 + j)) = LCase(a(i, Col)) Then
          Exit For
        ElseIf Len(b(k, c * 5 - 3 + j)) = 0 Then
          b(k, c * 5 - 3 + j) = a(i, Col)
          Exit For
        End If
      Next j
    Next c
    If a(i, ColOrder(6)) < b(k, 27) Or Len(b(k, 27)) = 0 Then b(k, 27) = a(i, ColOrder(6))
  Next i
  With Sheets("Mail")
    .UsedRange.Offset(1).ClearContents
    .Range("A2").Resize(k, 27).Value = b
  End With
End Sub
 

Gerrit.B

Board Regular
Joined
Aug 10, 2004
Messages
234
Office Version
  1. 2019
  2. 2016
Platform
  1. Windows
Assuming ..
  • Data on 'RemindersByExcel1' is sorted by Company
  • 'Mail' sheet already has the headings in A1:AA1 and any other existing data on that sheet can be removed
.. try

VBA Code:
Option Explicit
Option Base 1

Sub Rearrange_v5()
  Dim a As Variant, b As Variant, ColOrder As Variant
  Dim i As Long, j As Long, c As Long, Col As Long, k As Long
 
  ColOrder = Array(6, 3, 2, 4, 7, 5)
  With Sheets("RemindersByExcel1")
    a = .Range("A1", .Range("G" & .Rows.Count).End(xlUp)).Value
  End With
  ReDim b(1 To UBound(a), 1 To 27)
  For i = 2 To UBound(a)
    If a(i, 1) <> a(i - 1, 1) Then
      k = k + 1
      b(k, 1) = a(i, 1)
    End If
    For c = 1 To 5
      Col = ColOrder(c)
      For j = 0 To 4
        If LCase(b(k, c * 5 - 3 + j)) = LCase(a(i, Col)) Then
          Exit For
        ElseIf Len(b(k, c * 5 - 3 + j)) = 0 Then
          b(k, c * 5 - 3 + j) = a(i, Col)
          Exit For
        End If
      Next j
    Next c
    If a(i, ColOrder(6)) < b(k, 27) Or Len(b(k, 27)) = 0 Then b(k, 27) = a(i, ColOrder(6))
  Next i
  With Sheets("Mail")
    .UsedRange.Offset(1).ClearContents
    .Range("A2").Resize(k, 27).Value = b
  End With
End Sub
 

Gerrit.B

Board Regular
Joined
Aug 10, 2004
Messages
234
Office Version
  1. 2019
  2. 2016
Platform
  1. Windows
Hi Peter,

This works perfect!

Thanks
 
Last edited:

Peter_SSs

MrExcel MVP, Moderator
Joined
May 28, 2005
Messages
50,601
Office Version
  1. 365
Platform
  1. Windows
Good news. Thanks for the confirmation. :)
 

Forum statistics

Threads
1,141,286
Messages
5,705,517
Members
421,399
Latest member
hjweiss00

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Top