Transposing data in a specific format.

JohnBecks

New Member
Joined
Aug 9, 2021
Messages
4
Office Version
  1. 2019
Platform
  1. Windows
Hi,

I have an excel which has an unlimited number of data that needs to be transposed into a specific format. The number of columns is fixed to four but the number of rows is constantly increasing. I would appreciate the help.

Example : ( Data )

Customer Invoice Date Amount
Customer A A-1 01/08/2021 100
Customer A A-2 02/08/2021 125
Customer A A-3 03/08/2021 150
Customer A A-4 04/08/2021 175
Customer B B-1 04/08/2021 200
Customer B B-2 05/08/2021 225
Customer B B-3 06/08/2021 225
Customer B B-4 07/08/2021 250
Customer B B-5 08/08/2021 275
Customer C C-1 06/08/2021 300
Customer C C-2 07/08/2021 325
Customer C C-3 08/08/2021 350
Customer D D-1 09/08/2021 375

Into something like this - So for every

Customer AA-1A-2A-3A-4
Customer A01/08/202102/08/202103/08/202104/08/2021
Customer A100125150175
Customer BB-1B-2B-3B-4
Customer B04/08/202105/08/202106/08/202107/08/2021
Customer B200225225250
Customer BB-5---
Customer B08/08/2021---
Customer B275---
Customer CC-1C-2C-3-
Customer C06/08/202107/08/202108/08/2021-
Customer C300325350-
Customer DD-1---
Customer D09/08/2021---
Customer D375---

Appreciate all the help
 

Excel Facts

How can you turn a range sideways?
Copy the range. Select a blank cell. Right-click, Paste Special, then choose Transpose.

rpaulson

Well-known Member
Joined
Oct 4, 2007
Messages
1,211
try this on a copy of your file
VBA Code:
Sub Do_it()
wc = 2
wr = 1

For r = 2 To 14
cust = Cells(r, "A")
inv = Cells(r, "B")
iDate = Cells(r, "C")
amt = Cells(r, "D")

With Worksheets("Sheet2")

If cust <> .Cells(wr, "A") Or wc > 5 Then
    wc = 2
    wr = wr + 3
End If

.Cells(wr, "A") = cust
.Cells(wr, wc) = inv
.Cells(wr + 1, wc) = iDate
.Cells(wr + 2, wc) = amt
wc = wc + 1
End With

Next r
 

JohnBecks

New Member
Joined
Aug 9, 2021
Messages
4
Office Version
  1. 2019
Platform
  1. Windows
try this on a copy of your file
VBA Code:
Sub Do_it()
wc = 2
wr = 1

For r = 2 To 14
cust = Cells(r, "A")
inv = Cells(r, "B")
iDate = Cells(r, "C")
amt = Cells(r, "D")

With Worksheets("Sheet2")

If cust <> .Cells(wr, "A") Or wc > 5 Then
    wc = 2
    wr = wr + 3
End If

.Cells(wr, "A") = cust
.Cells(wr, wc) = inv
.Cells(wr + 1, wc) = iDate
.Cells(wr + 2, wc) = amt
wc = wc + 1
End With

Next r

Hi R.paulson,

I got the following error when pasting the code: " Compile Error - Expected end sub"
 

Peter_SSs

MrExcel MVP, Moderator
Joined
May 28, 2005
Messages
51,145
Office Version
  1. 365
Platform
  1. Windows
Welcome to the MrExcel board!

Not sure where the data is or where the results should go but this assumes data in columns A:D and it puts the results starting in column F

VBA Code:
Sub Rearrange()
  Dim a As Variant, b As Variant
  Dim i As Long, c As Long, k As Long, z As Long
 
  a = Range("A1", Range("D" & Rows.Count).End(xlUp)).Value
  ReDim b(1 To Rows.Count, 1 To 2)
  z = 2:  k = -3
  For i = 2 To UBound(a)
    If a(i, 1) <> a(i - 1, 1) Then
      k = k + 4
      b(k, 1) = a(i, 1): b(k + 1, 1) = a(i, 1): b(k + 2, 1) = a(i, 1)
      c = 1
    End If
    c = c + 1
    If c > z Then
      ReDim Preserve b(1 To UBound(b), 1 To c)
      z = c
    End If
    b(k, c) = a(i, 2): b(k + 1, c) = a(i, 3): b(k + 2, c) = a(i, 4)
  Next i
  Range("F1").Resize(k + 2, UBound(b, 2)).Value = b
End Sub

Here is my sample data and results.

JohnBecks.xlsm
ABCDEFGHIJK
1CustomerInvoiceDateAmountCustomer AA-1A-2A-3A-4
2Customer AA-11/08/2021100Customer A1/08/20212/08/20213/08/20214/08/2021
3Customer AA-22/08/2021125Customer A100125150175
4Customer AA-33/08/2021150
5Customer AA-44/08/2021175Customer BB-1B-2B-3B-4B-5
6Customer BB-14/08/2021200Customer B4/08/20215/08/20216/08/20217/08/20218/08/2021
7Customer BB-25/08/2021225Customer B200225225250275
8Customer BB-36/08/2021225
9Customer BB-47/08/2021250Customer CC-1C-2C-3
10Customer BB-58/08/2021275Customer C6/08/20217/08/20218/08/2021
11Customer CC-16/08/2021300Customer C300325350
12Customer CC-27/08/2021325
13Customer CC-38/08/2021350Customer DD-1
14Customer DD-19/08/2021375Customer D9/08/2021
15Customer D375
Sheet1
 

JohnBecks

New Member
Joined
Aug 9, 2021
Messages
4
Office Version
  1. 2019
Platform
  1. Windows

ADVERTISEMENT

Hello Peter,

Appreciate the assistance with the above.

It definitely works. However, would it be possible to limit the number of columns to just five? This would be useful as some customers have over 1000 invoices.

So, instead of this

Customer BB-1B-2B-3B-4B-5
Customer B04/08/202105/08/202106/08/202107/08/202108/08/2021
Customer B200225225250275

I can get something like this,

Customer BB-1B-2B-3B-4
Customer B04/08/202105/08/202106/08/202107/08/2021
Customer B200225225250
Customer BB-5
Customer B08/08/2021
Customer B275

Appreciate it
 

Peter_SSs

MrExcel MVP, Moderator
Joined
May 28, 2005
Messages
51,145
Office Version
  1. 365
Platform
  1. Windows
Try this version

VBA Code:
Sub Rearrange_v2()
  Dim a As Variant, b As Variant
  Dim i As Long, c As Long, k As Long
  
  Const MaxCols As Long = 5
  
  a = Range("A1", Range("D" & Rows.Count).End(xlUp)).Value
  ReDim b(1 To Rows.Count, 1 To MaxCols)
  k = -3
  For i = 2 To UBound(a)
    If a(i, 1) <> a(i - 1, 1) Then
      k = k + 4
      b(k, 1) = a(i, 1): b(k + 1, 1) = a(i, 1): b(k + 2, 1) = a(i, 1)
      c = 1
    End If
    c = c + 1
    If c > MaxCols Then
      c = 2
      k = k + 3
      b(k, 1) = a(i, 1): b(k + 1, 1) = a(i, 1): b(k + 2, 1) = a(i, 1)
    End If
    b(k, c) = a(i, 2): b(k + 1, c) = a(i, 3): b(k + 2, c) = a(i, 4)
  Next i
  Range("F1").Resize(k + 2, UBound(b, 2)).Value = b
End Sub
 
Solution

JohnBecks

New Member
Joined
Aug 9, 2021
Messages
4
Office Version
  1. 2019
Platform
  1. Windows
Try this version

VBA Code:
Sub Rearrange_v2()
  Dim a As Variant, b As Variant
  Dim i As Long, c As Long, k As Long
 
  Const MaxCols As Long = 5
 
  a = Range("A1", Range("D" & Rows.Count).End(xlUp)).Value
  ReDim b(1 To Rows.Count, 1 To MaxCols)
  k = -3
  For i = 2 To UBound(a)
    If a(i, 1) <> a(i - 1, 1) Then
      k = k + 4
      b(k, 1) = a(i, 1): b(k + 1, 1) = a(i, 1): b(k + 2, 1) = a(i, 1)
      c = 1
    End If
    c = c + 1
    If c > MaxCols Then
      c = 2
      k = k + 3
      b(k, 1) = a(i, 1): b(k + 1, 1) = a(i, 1): b(k + 2, 1) = a(i, 1)
    End If
    b(k, c) = a(i, 2): b(k + 1, c) = a(i, 3): b(k + 2, c) = a(i, 4)
  Next i
  Range("F1").Resize(k + 2, UBound(b, 2)).Value = b
End Sub
Works perfectly.

Appreciate it very much.

Thank you!
 

Peter_SSs

MrExcel MVP, Moderator
Joined
May 28, 2005
Messages
51,145
Office Version
  1. 365
Platform
  1. Windows
You're welcome. Thanks for the confirmation. :)
 

Forum statistics

Threads
1,144,278
Messages
5,723,464
Members
422,498
Latest member
KAT112014

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