Transpose every x amount of columns to rows, keeping cell of first column on each row

J

jerxjac

New Member
Joined
Dec 28, 2020
Messages
2
Office Version
  1. 2013
Platform
  1. Windows
What I try to achieve is to convert my rows to columns, but a bit different that mostly done
It has to be chopped in to 3 or 4 columns that has to be moved to a row on a new sheet, but each row needs to has to start with the first cell of the original row.

Hard to explane but I think these pictures tell the story better.

Example1.png


To

ToBe.png


Hope to get some help to achieve this goal.

File attached: link
 

Excel Facts

Add Bullets to Range
Select range. Press Ctrl+1. On Number tab, choose Custom. Type Alt+7 then space then @ sign (using 7 on numeric keypad)
Sort by date Sort by votes
Hi & welcome to MrExcel.
How about
VBA Code: 
Sub jerxjac()
   Dim Ary As Variant, Nary As Variant
   Dim r As Long, c As Long, nr As Long, nc As Long
   
   Ary = Sheets("Sheet1").Range("A1").CurrentRegion.Value2
   ReDim Nary(1 To UBound(Ary) * UBound(Ary, 2), 1 To 5)
   
   For r = 2 To UBound(Ary)
      For c = 2 To 16 Step 4
         If Ary(r, c) <> "" Then
            nr = nr + 1
            Nary(nr, 1) = Ary(r, 1)
            For nc = 2 To 5
               Nary(nr, nc) = Ary(r, c + nc - 2)
            Next nc
         End If
      Next c
      For c = 18 To UBound(Ary, 2) Step 3
         If Ary(r, c) <> "" Then
            nr = nr + 1
            Nary(nr, 1) = Ary(r, 1)
            For nc = 2 To 4
               Nary(nr, nc) = Ary(r, c + nc - 2)
            Next nc
         End If
      Next c
   Next r
   Sheets("sheet2").Range("A2").Resize(nr, 5).Value = Nary
End Sub
 
Upvote 0
Solution
You're welcome & thanks for the feedback.
 
Upvote 0
Extend A8:F14 to A8:F35
because of large amount of Data I copy A8:F14.

trans.xlsm
ABCDEFGHIJKLMNOPQRSTUVWXYZ
1Art_codeC1Amount C1Unit C1% lostC2Amount C2Unit C2% lostC3Amount C3Unit C3% lostC4Amount C4Unit C4% lost
2A00001C001015KCD3C0001058KCD3C001015KCD3C00012555KCD10Box UC1PCSBox outer1PCSInlet5PCS
3A00002C001026KCD4C0001057KCD3C001026KCD4C00010560KCD10Box UC2PCSBox outer1PCSInlet5PCS
4A00003C001057KCD5C0001057KCD3C001057KCD5C00010565KCD10Box UC3PCSBox outer1PCSInlet5PCS
5A00004C001055KCD5C0001058KCD3C001055KCD5C00010570KCD10Box UC4PCSBox outer1PCSInlet5PCS
6
7
8A00001C001015KCD3 
9A00001C0001058KCD3 
10A00001C001015KCD3 
11A00001C00012555KCD10 
12A00001Box UC1PCS  
13A00001Box outer1PCS  
14A00001Inlet5PCS  
Sheet5
Cell Formulas
RangeFormula
A8:F14A8=TRIM(MID(SUBSTITUTE(TRIM(MID(SUBSTITUTE(CONCAT(SUBSTITUTE(SUBSTITUTE(SUBSTITUTE(MID("\"&TEXTJOIN({",",",",",","*",",",",",",","*",",",",",",","*",",",",",",","*",",",",","*",",",",","*",",",",","*"},1,$B$2:$Z$5)&";",TRANSPOSE(FIND("|",SUBSTITUTE(","&TEXTJOIN(",",1,$B$2:$Z$5)&",",",","|",COUNTIFS(OFFSET(INDIRECT(ADDRESS(ROW($B$2),COLUMN($B$2))),0,0,ROW(INDIRECT("1:"&ROWS($B$2:$Z$5))),COLUMNS($B$2:$Z$5)),"<>")-COUNTIF(OFFSET(INDIRECT(ADDRESS(ROW($B$2)-1+ROW(INDIRECT("1:"&ROWS($B$2:$Z$5))),COLUMN($B$2))),0,0,1,COLUMNS($B$2:$Z$5)),"<>")+1))),TRANSPOSE(MMULT(LEN($B$2:$Z$5),ROW(INDIRECT("1:"&COLUMNS($B$2:$Z$5)))^0)+COUNTIF(OFFSET(INDIRECT(ADDRESS(ROW($B$2)-1+ROW(INDIRECT("1:"&ROWS($B$2:$Z$5))),COLUMN($B$2))),0,0,1,COLUMNS($B$2:$Z$5)),"<>"))),"*",";*"),"\","*"),"*",MID(""&TEXTJOIN(",",1,$A$2:$A$5)&",",TRANSPOSE(FIND("|",SUBSTITUTE(","&TEXTJOIN(",",1,$A$2:$A$5)&",",",","|",(ROW(INDIRECT("1:"&ROWS($A$2:$A$5)))-1)*COLUMNS($A$2:$A$5)+1),(ROW(INDIRECT("1:"&ROWS($A$2:$A$5)))-1)*COLUMNS($A$2:$A$5)+1)),TRANSPOSE(FIND("|",SUBSTITUTE(","&TEXTJOIN(",",1,$A$2:$A$5)&",",",","|",(ROW(INDIRECT("2:"&ROWS($A$2:$A$5)+1))-1)*COLUMNS($A$2:$A$5)+1),(ROW(INDIRECT("2:"&ROWS($A$2:$A$5)+1))-1)*COLUMNS($A$2:$A$5)+1))-TRANSPOSE(FIND("|",SUBSTITUTE(","&TEXTJOIN(",",1,$A$2:$A$5)&",",",","|",(ROW(INDIRECT("1:"&ROWS($A$2:$A$5)))-1)*COLUMNS($A$2:$A$5)+1),(ROW(INDIRECT("1:"&ROWS($A$2:$A$5)))-1)*COLUMNS($A$2:$A$5)+1))))),";",REPT(" ",999)),(ROW()-ROW(A$8)+1)*999-998,999)),",",REPT(" ",999)),(COLUMN()-COLUMN(A$8)+1)*999-998,999))
Press CTRL+SHIFT+ENTER to enter array formulas.


trans.gif
 
Upvote 0
@Dossfm0q
How exactly is that going to help the OP, who is using 2013 which doesn't have either TextJoin or Concat?
Also when usng that on the OP's data I get
A00001C001015KCD3
A00001C0001058KCD3
A00001C00011145KCD5
A00001C00012555KCD10
A00001Box UC1PCS
A00001Box Outer00625PCS
A00001INTE1PCSPCS
A00002C001026KCD4
A00002C0001057KCD3
A00002C00012540KCD7
A00002C00011160KCD10


Which is obviously not right.
 
Upvote 0
I totally Aggrege with you Fluff 2013 which doesn't have either TextJoin or Concat ,but this tested as shown in Pic and it is Ok with 2019
Transpose amount of columns to rows.xlsm
ABCDE
1Art_codeCAmount CUnit C% lost
2A00001C001015KCD3
3A00001C0001058KCD3
4A00001C001015KCD3
5A00001C00012555KCD10
6A00001Box UC1PCS 
7A00001Box outer1PCS 
8A00001Inlet5PCS 
Sheet2
Cell Formulas
RangeFormula
A2:E8A2=TRIM(MID(SUBSTITUTE(TRIM(MID(SUBSTITUTE(CONCAT(SUBSTITUTE(SUBSTITUTE(SUBSTITUTE(MID("\"&TEXTJOIN({",",",",",","*",",",",",",","*",",",",",",","*",",",",",",","*",",",",","*",",",",","*",",",",","*"},1,Sheet1!$B$2:$Z$5)&";",TRANSPOSE(FIND("|",SUBSTITUTE(","&TEXTJOIN(",",1,Sheet1!$B$2:$Z$5)&",",",","|",COUNTIFS(OFFSET(INDIRECT(ADDRESS(ROW(Sheet1!$B$2),COLUMN(Sheet1!$B$2),,,"Sheet1")),0,0,ROW(INDIRECT("1:"&ROWS(Sheet1!$B$2:$Z$5))),COLUMNS(Sheet1!$B$2:$Z$5)),"<>")-COUNTIF(OFFSET(INDIRECT(ADDRESS(ROW(Sheet1!$B$2)-1+ROW(INDIRECT("1:"&ROWS(Sheet1!$B$2:$Z$5))),COLUMN(Sheet1!$B$2),,,"Sheet1")),0,0,1,COLUMNS(Sheet1!$B$2:$Z$5)),"<>")+1))),TRANSPOSE(MMULT(LEN(Sheet1!$B$2:$Z$5),ROW(INDIRECT("1:"&COLUMNS(Sheet1!$B$2:$Z$5)))^0)+COUNTIF(OFFSET(INDIRECT(ADDRESS(ROW(Sheet1!$B$2)-1+ROW(INDIRECT("1:"&ROWS(Sheet1!$B$2:$Z$5))),COLUMN(Sheet1!$B$2),,,"Sheet1")),0,0,1,COLUMNS(Sheet1!$B$2:$Z$5)),"<>"))),"*",";*"),"\","*"),"*",MID(""&TEXTJOIN(",",1,Sheet1!$A$2:$A$5)&",",TRANSPOSE(FIND("|",SUBSTITUTE(","&TEXTJOIN(",",1,Sheet1!$A$2:$A$5)&",",",","|",(ROW(INDIRECT("1:"&ROWS(Sheet1!$A$2:$A$5)))-1)*COLUMNS(Sheet1!$A$2:$A$5)+1),(ROW(INDIRECT("1:"&ROWS(Sheet1!$A$2:$A$5)))-1)*COLUMNS(Sheet1!$A$2:$A$5)+1)),TRANSPOSE(FIND("|",SUBSTITUTE(","&TEXTJOIN(",",1,Sheet1!$A$2:$A$5)&",",",","|",(ROW(INDIRECT("2:"&ROWS(Sheet1!$A$2:$A$5)+1))-1)*COLUMNS(Sheet1!$A$2:$A$5)+1),(ROW(INDIRECT("2:"&ROWS(Sheet1!$A$2:$A$5)+1))-1)*COLUMNS(Sheet1!$A$2:$A$5)+1))-TRANSPOSE(FIND("|",SUBSTITUTE(","&TEXTJOIN(",",1,Sheet1!$A$2:$A$5)&",",",","|",(ROW(INDIRECT("1:"&ROWS(Sheet1!$A$2:$A$5)))-1)*COLUMNS(Sheet1!$A$2:$A$5)+1),(ROW(INDIRECT("1:"&ROWS(Sheet1!$A$2:$A$5)))-1)*COLUMNS(Sheet1!$A$2:$A$5)+1))))),";",REPT(" ",999)),(ROW()-ROW(A$2)+1)*999-998,999)),",",REPT(" ",999)),(COLUMN()-COLUMN(A$2)+1)*999-998,999))
Press CTRL+SHIFT+ENTER to enter array formulas.


By Selecting "A2:E29" and Pressing CTRL+SHIFT+ENTER result below

Art_codeCAmount CUnit C% lost
A00001C001015KCD3
A00001C0001058KCD3
A00001C001015KCD3
A00001C00012555KCD10
A00001Box UC1PCS
A00001Box outer1PCS
A00001Inlet5PCS
A00002C001026KCD4
A00002C0001057KCD3
A00002C001026KCD4
A00002C00010560KCD10
A00002Box UC2PCS
A00002Box outer1PCS
A00002Inlet5PCS
A00003C001057KCD5
A00003C0001057KCD3
A00003C001057KCD5
A00003C00010565KCD10
A00003Box UC3PCS
A00003Box outer1PCS
A00003Inlet5PCS
A00004C001055KCD5
A00004C0001058KCD3
A00004C001055KCD5
A00004C00010570KCD10
A00004Box UC4PCS
A00004Box outer1PCS
A00004Inlet5PCS
 
Upvote 0
Code: 
Sub Transpose_every_x_amount_of_columns_to_rows()


Application.ScreenUpdating = False


    ArrPart1 = "INDIRECT(ADDRESS((CEILING(ROW()-ROW($A$2)+1,7)/7)+ROW($A$2)-1,1,,,""Sheet1""))"
    ArrPart2 = "INDIRECT(ADDRESS((CEILING(ROW()-ROW($A$2)+1,7)/7)+1,COLUMN()-COLUMN($A$2)+COLUMN($A$2)-1+((MOD((ROW()-ROW($A$2)+1)-1,7)+1)-1)*IF((MOD((ROW()-ROW($A$2)+1)-1,7)+1)<=4,4,3)+IF((MOD((ROW()-ROW($A$2)+1)-1,7)+1)<=4,0,4)+1,,,""Sheet1""))"
    
    With Worksheets("Sheet2").Range("A2:E500")
    .Clear
    'FormulaArray not works
    '.FormulaArray = "=IF(COLUMN()-COLUMN($A$2)+1<=1,IF(CELL(""contents"",ArrPart1)<>"""",ArrPart1,""""),IF(COLUMN()-COLUMN($A$2)+COLUMN($A$2)-1<=IF((MOD((ROW()-ROW($A$2)+1)-1,7)+1)<=4,4,3),IF(CELL(""contents"",ArrPart2)<>"""",ArrPart2,""""),""""))"
    .Formula = "=IF(COLUMN()-COLUMN($A$2)+1<=1,IF(CELL(""contents"",ArrPart1)<>"""",ArrPart1,""""),IF(COLUMN()-COLUMN($A$2)+COLUMN($A$2)-1<=IF((MOD((ROW()-ROW($A$2)+1)-1,7)+1)<=4,4,3),IF(CELL(""contents"",ArrPart2)<>"""",ArrPart2,""""),""""))"
    .Replace "ArrPart1", ArrPart1
    .Replace "ArrPart2", ArrPart2
    
            Call Conditional_Formating(.Cells(1, 1).Resize(500, 1), .Cells(1, 1 + 1).Resize(500, 4))
    End With
    
Application.ScreenUpdating = True
End Sub


Sub Conditional_Formating(DestRng1 As Range, DestRng2 As Range)

Dim FrstCll As String, ScndCll As String
  
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    With DestRng1
        FrstCll = .Cells(1, 1).Address(False, True)
        ScndCll = .Cells(1, 1).Address(True, True)
        
        .FormatConditions.Delete
        .FormatConditions.Add Type:=xlExpression, Formula1:= _
            "=AND(" & FrstCll & "<>"""",ROW()-ROW(" & ScndCll & ")+1>0)"
        .FormatConditions(.FormatConditions.Count).SetFirstPriority
        .FormatConditions(.FormatConditions.Count).SetFirstPriority
        With .FormatConditions(1).Borders(xlLeft)
            .LineStyle = xlContinuous
            .TintAndShade = 0
            .Weight = xlThin
        End With
        With .FormatConditions(1).Borders(xlBottom)
            .LineStyle = xlContinuous
            .TintAndShade = 0
            .Weight = xlThin
        End With
        With .FormatConditions(1).Interior
            .PatternColorIndex = xlAutomatic
            .ThemeColor = xlThemeColorAccent2
            .TintAndShade = 0.399945066682943
        End With
        .FormatConditions(1).StopIfTrue = False
    End With

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    
    
    With DestRng2
    
        FrstCll = .Cells(1, 1).Address(False, True)
        ScndCll = .Cells(1, 1).Address(True, True)
        .FormatConditions.Delete
        .FormatConditions.Add Type:=xlExpression, Formula1:= _
            "=AND(" & FrstCll & "<>"""",ROW()-ROW(" & ScndCll & ")+1>0,OR(MOD((ROW()-ROW(" & ScndCll & ")+1)-1,7)+1=1,MOD((ROW()-ROW(" & ScndCll & ")+1)-1,7)+1=3))"
        .FormatConditions(.FormatConditions.Count).SetFirstPriority
        With .FormatConditions(1).Font
            .Bold = False
            .Italic = False
            .ThemeColor = xlThemeColorDark1
            .TintAndShade = 0
        End With
        With .FormatConditions(1).Borders(xlRight)
            .LineStyle = xlContinuous
            .TintAndShade = 0
            .Weight = xlThin
        End With
        With .FormatConditions(1).Borders(xlBottom)
            .LineStyle = xlContinuous
            .TintAndShade = 0
            .Weight = xlThin
        End With
        With .FormatConditions(1).Interior
            .PatternColorIndex = xlAutomatic
            .ThemeColor = xlThemeColorAccent5
            .TintAndShade = -0.249946592608417
        End With
        .FormatConditions(1).StopIfTrue = False
        .FormatConditions.Add Type:=xlExpression, Formula1:= _
            "=AND(" & FrstCll & "<>"""",ROW()-ROW(" & ScndCll & ")+1>0,OR(MOD((ROW()-ROW(" & ScndCll & ")+1)-1,7)+1=2,MOD((ROW()-ROW(" & ScndCll & ")+1)-1,7)+1=4))"
        .FormatConditions(.FormatConditions.Count).SetFirstPriority
        With .FormatConditions(1).Borders(xlRight)
            .LineStyle = xlContinuous
            .TintAndShade = 0
            .Weight = xlThin
        End With
        With .FormatConditions(1).Borders(xlBottom)
            .LineStyle = xlContinuous
            .TintAndShade = 0
            .Weight = xlThin
        End With
        With .FormatConditions(1).Interior
            .PatternColorIndex = xlAutomatic
            .ThemeColor = xlThemeColorAccent5
            .TintAndShade = 0.599963377788629
        End With
        .FormatConditions(1).StopIfTrue = False
        .FormatConditions.Add Type:=xlExpression, Formula1:= _
            "=AND(" & FrstCll & "<>"""",ROW()-ROW(" & ScndCll & ")+1>0,OR(MOD((ROW()-ROW(" & ScndCll & ")+1)-1,7)+1=5,MOD((ROW()-ROW(" & ScndCll & ")+1)-1,7)+1=7))"
        .FormatConditions(.FormatConditions.Count).SetFirstPriority
        With .FormatConditions(1).Borders(xlRight)
            .LineStyle = xlContinuous
            .TintAndShade = 0
            .Weight = xlThin
        End With
        With .FormatConditions(1).Borders(xlBottom)
            .LineStyle = xlContinuous
            .TintAndShade = 0
            .Weight = xlThin
        End With
        With .FormatConditions(1).Interior
            .PatternColorIndex = xlAutomatic
            .ThemeColor = xlThemeColorAccent2
            .TintAndShade = 0.399945066682943
        End With
        .FormatConditions(1).StopIfTrue = False
        .FormatConditions.Add Type:=xlExpression, Formula1:= _
            "=AND(" & FrstCll & "<>"""",ROW()-ROW(" & ScndCll & ")+1>0,MOD((ROW()-ROW(" & ScndCll & ")+1)-1,7)+1=6)"
        .FormatConditions(.FormatConditions.Count).SetFirstPriority
        With .FormatConditions(1).Borders(xlRight)
            .LineStyle = xlContinuous
            .TintAndShade = 0
            .Weight = xlThin
        End With
        With .FormatConditions(1).Borders(xlBottom)
            .LineStyle = xlContinuous
            .TintAndShade = 0
            .Weight = xlThin
        End With
        With .FormatConditions(1).Interior
            .PatternColorIndex = xlAutomatic
            .ThemeColor = xlThemeColorAccent4
            .TintAndShade = 0.599963377788629
        End With
        .FormatConditions(1).StopIfTrue = False
    End With
  
End Sub
 
Upvote 0
You must log in or register to reply here.

Similar threads

P
  • Solved
Filtering text data based on unique names and then pasting all the data into one single cell for each name
Replies
4
Views
115
p49
P
A
  • Solved
take amount from last row in listbox on form and put into next column
Replies
7
Views
110
Abdo
A
J
  • Solved
First (and last) occurrence of set of values in a row gives corresponding column value
Replies
2
Views
402
jimmychacha
J
G
  • Question Question
Convert formula to value in a table column using VBA
Replies
7
Views
809
gsinkinson
G
D
  • Question Question
How to keep a tally of matching letters in separate cells
Replies
4
Views
519
Davenil
D

Forum statistics

Threads
1,223,164
Messages
6,170,444
Members
452,326
Latest member
johnshaji

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