Rows to Columns

G

Gerrit.B

Board Regular
Joined
Aug 10, 2004
Messages
237
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: 44
Sort by date Sort by votes

Excel Facts

Which came first: VisiCalc or Lotus 1-2-3?
Dan Bricklin and Bob Frankston debuted VisiCalc in 1979 as a Visible Calculator. Lotus 1-2-3 debuted in the early 1980's, from Mitch Kapor.
Gerrit.B said:
See results above.
Click to expand...
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
 
Upvote 0
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
 
Upvote 0
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
 
Upvote 0
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.
 
Upvote 0
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
 
Upvote 0
Peter_SSs said:
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
Click to expand...
 
Upvote 0
Hi Peter,

This works perfect!

Thanks
 
Last edited:
Upvote 0
You must log in or register to reply here.

Similar threads

R
  • Question
Split row into two rows, one header and one line row
Replies
2
Views
61
rrmando18
R
M
  • Solved
VBA to find most recent Invoice Date for each Customer
2
Replies
10
Views
610
kevin9999
K
I
  • Question
Open selected customer in my main database
Replies
2
Views
160
ipbr21054
I
C
  • Solved
Manipulate the appearance of a spreadsheet in VBA
2
Replies
14
Views
386
mumps
mumps
I
  • Solved
Type in field to jump to first instance of what was typed from a drop down list
2 3 4
Replies
38
Views
868
ipbr21054
I

Forum statistics

Threads
1,214,932
Messages
6,122,332
Members
449,077
Latest member
jmsotelo

Share this page

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