# Rows to Columns

#### Gerrit.B

##### Board Regular
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
10.1 KB · Views: 43

#### Gerrit.B

##### Board Regular
My code does what you asked for in post #28.
Did you at least try it?
I will try it tomorrow.

### Excel Facts

How to create a cell-sized chart?
Tiny charts, called Sparklines, were added to Excel 2010. Look for Sparklines on the Insert tab.

#### Peter_SSs

##### MrExcel MVP, Moderator
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
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

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

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
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

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
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
Hi Peter,

This works perfect!

Thanks

Last edited:

#### Peter_SSs

##### MrExcel MVP, Moderator
Good news. Thanks for the confirmation.

Replies
3
Views
94
Replies
6
Views
47
Replies
3
Views
122
Replies
7
Views
130
Replies
0
Views
87

1,137,347
Messages
5,680,958
Members
419,946
Latest member
Trickay

### 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.

### Which adblocker are you using?

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

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