Transpose horizontal data to vertical data with automatic update

N

nathanmav

Board Regular
Joined
Dec 11, 2012
Messages
123
Office Version
  1. 2019
  2. 2016
Platform
  1. Windows
Hi,

Can anyone have an idea on how to transpose horizontal data to a vertical data. Check the sample in the picture below:

8b2b6f1897510ff591d974210b364a3c-full.png
[/URL] url picture[/IMG]
 
Last edited:
Sort by date Sort by votes
Code: 
Public Sub test()


Application.ScreenUpdating = False
Dim b As Long
 Cells.Clear
    ActiveWindow.DisplayGridlines = False
R1 = "#, Desc , Desc2 ,  Refrenace No.  ,Desc,Rev0,,,,Rev1,,,,Rev2,,,,Rev3,,,,Rev4,,,,Rev5,,,,Remarks"
R2 = ",,,,,Date Sub, Date Rec ,      Days      ,Code,Date Sub,Date Rec,Days,Code,Date Sub,Date Rec,Days,Code,Date Sub,Date Rec,Days,Code,Date Sub,Date Rec,Days,Code,Date Sub,Date Rec,Days,Code,"
R3 = "1,dsdfdsf,sfdsf,xx-xx-xx-00001,ar,01-jan-19,05-jan-19,4,C,07-jan-19,10-jan-19,3,C,12-Jan-19,15-jan-19,3,B,,,,,,,,,,,,,"
R4 = "2,hjhjhgj,vcvbcvb,xx-xx-xx-00002,ar,01-jan-19,10-Jan-19,9,C,12-Jan-19,15-Jan-19,3,C,16-jan-19,20-jan-19,4,C,21-Jn-19,25-Jn-19,4,B,,,,,,,,,"
TR = R1 & ";" & R2 & ";" & R3 & ";" & R4
For R = 2 To 5
    For c = 1 To 30
        With Cells(R, c)
        If R = 2 And (c <= 5 Or c = 30) Then .Resize(2, 1).Merge
        If R = 2 And (c = 6 Or c = 10 Or c = 14 Or c = 18 Or c = 22 Or c = 26) Then .Resize(1, 4).Merge
        .Value = Split(Split(TR, ";")(R - 2), ",")(c - 1)
        
        End With
    Next
Next




Cells.EntireColumn.AutoFit




'COLOR
With Cells(2, 1).Resize(2, 30)
    With .Interior
        .Pattern = xlSolid
        .Color = RGB(253, 233, 217)
    End With
End With
'Borders
With Cells(2, 1).Resize(5, 30)
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
   For b = 7 To 12
        With .Borders(b)
            .LineStyle = xlContinuous
            .ColorIndex = 0
            .TintAndShade = 0
            .Weight = xlHairline
        End With
    Next
        
End With




[B8] = "=CONCATENATE(SUBSTITUTE(IF(F4<>"""",""*""&CONCATENATE(""Rev0"","","",TEXT(F4,""dd-mmm-yy""),"","",TEXT(G4,""dd-mmm-yy""),"","",H4,"","",I4)&"";"","""")&IF(J4<>"""",""*""&CONCATENATE(""Rev1"","","",TEXT(J4,""dd-mmm-yy""),"","",TEXT(K4,""dd-mmm-yy""),"","",L4,"","",M4)&"";"","""") &IF(N4<>"""",""*""&CONCATENATE(""Rev2"","","",TEXT(N4,""dd-mmm-yy""),"","",TEXT(O4,""dd-mmm-yy""),"","",P4,"","",Q4)&"";"","""")&IF(R4<>"""",""*""&CONCATENATE(""Rev3"","","",TEXT(R4,""dd-mmm-yy""),"","",TEXT(S4,""dd-mmm-yy""),"","",T4,"","",U4)&"";"","""") &IF(V4<>"""",""*""&CONCATENATE(""Rev4"","","",TEXT(V4,""dd-mmm-yy""),"","",TEXT(W4,""dd-mmm-yy""),"","",X4,"","",Y4)&"";"","""")&IF(Z4<>"""",""*""&CONCATENATE(""Rev5"","","",TEXT(Z4,""dd-mmm-yy""),"","",TEXT(AA4,""dd-mmm-yy""),"","",AB4,"","",AC4)&"";"",""""),""*"",CONCATENATE(B4,"","",C4,"","",D4,"","",E4)&"","")" & _
",SUBSTITUTE(IF(F5<>"""",""*""&CONCATENATE(""Rev0"","","",TEXT(F5,""dd-mmm-yy""),"","",TEXT(G5,""dd-mmm-yy""),"","",H5,"","",I5)&"";"","""")&IF(J5<>"""",""*""&CONCATENATE(""Rev1"","","",TEXT(J5,""dd-mmm-yy""),"","",TEXT(K5,""dd-mmm-yy""),"","",L5,"","",M5)&"";"","""") &IF(N5<>"""",""*""&CONCATENATE(""Rev2"","","",TEXT(N5,""dd-mmm-yy""),"","",TEXT(O5,""dd-mmm-yy""),"","",P5,"","",Q5)&"";"","""")&IF(R5<>"""",""*""&CONCATENATE(""Rev3"","","",TEXT(R5,""dd-mmm-yy""),"","",TEXT(S5,""dd-mmm-yy""),"","",T5,"","",U5)&"";"","""") &IF(V5<>"""",""*""&CONCATENATE(""Rev4"","","",TEXT(V5,""dd-mmm-yy""),"","",TEXT(W5,""dd-mmm-yy""),"","",X5,"","",Y5)&"";"","""")&IF(Z5<>"""",""*""&CONCATENATE(""Rev5"","","",TEXT(Z5,""dd-mmm-yy""),"","",TEXT(AA5,""dd-mmm-yy""),"","",AB5,"","",AC5)&"";"",""""),""*"",CONCATENATE(B5,"","",C5,"","",D5,"","",E5)&"",""))"




For R = 9 To 20
    For c = 1 To 30
        With Cells(R, c)
       ' If c = 7 Then .Resize(1, 2).Merge, Merge cell to fit contents not function
        
        
        End With
    Next
Next












''''''''''''''''''''''''''''''''''''''''''''








On Error Resume Next ' may it Long not work
    Range("B10:L40").FormulaArray = "=TRIM(MID(SUBSTITUTE(IFERROR(MID(B$8,FIND(""|"",SUBSTITUTE("";""&B$8&"";"","";"",""|"",(ROW()-ROW(B$10)+1))),FIND("";"",B$8&"";"",FIND(""|"",SUBSTITUTE("";""&B$8&"";"","";"",""|"",(ROW()-ROW(B$10)+1))))-FIND(""|"",SUBSTITUTE("";""&B$8&"";"","";"",""|"",(ROW()-ROW(B$10)+1)))),""""),"","",REPT("" "",99)),(COLUMN()-COLUMN(B$10)+1)*99-98,99))"
On Error GoTo 0
'''''''''''''''''''' workwill
    Range("B10:L20").FormulaArray = "=TRIM(MID(SUBSTITUTE(TRIM(MID(SUBSTITUTE(B8,"";"",REPT("" "",999)),(ROW()-ROW(B$10)+1)*999-998,999)),"","",REPT("" "",999)),(COLUMN()-COLUMN(B$10)+1)*999-998,999))"
'COLOR




 
With Cells(9, 1).Resize(1, 11)
    With .Interior
        .Pattern = xlSolid
        .Color = RGB(253, 233, 217)
    End With
End With
'Borders
 
With Cells(9, 1).Resize(15, 11)




        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
   For b = 7 To 12
        With .Borders(b)
            .LineStyle = xlContinuous
            .ColorIndex = 0
            .TintAndShade = 0
            .Weight = xlHairline
        End With
    Next
        
End With


Application.ScreenUpdating = False


End Sub
 
Last edited:
Upvote 0

Excel Facts

How to fill five years of quarters?
Type 1Q-2023 in a cell. Grab the fill handle and drag down or right. After 4Q-2023, Excel will jump to 1Q-2024. Dash can be any character.
@Dossfm0q
I think OP needs something more flexible
- there can be up to 8 revisions
- number of rows can vary
- the dates will be different next time
etc
 
Upvote 0
as you want

'Enter Data

For Table Size
RevNum = 6 'Rev Num
Rws = 10 'Rows Num

and these for Table position
StrRw = 2 'Start Row
StrCl = 1 'Start Row ' 1 = column A, 2= B

StrRw = StrRw - 1
StrCl = StrCl - 1
'Addjust Des Num with increaing text and comma



Code: 
Public Sub test()


    Application.ScreenUpdating = False
    
    Cells.Clear
    Cells.ColumnWidth = 8.43
    ActiveWindow.DisplayGridlines = False


    Dim Tile() As String, DesClTXT() As String, RevSubTXT() As String
    Dim N As Long, B As Long, RevNum As Long, CL As Long, Rw As Long, Rws As Long, StrRw As Long, StrCl As Long
    
    ''''''''''''''''''''''''''''''''''''''''''''''''''''
    ''''''''''''''''''''''''''''''''''''''''''''''''''''
    'Enter Data
    
    RevNum = 6 'Rev Num
    Rws = 10 'Rows Num
    StrRw = 2 'Start Row
    StrCl = 1 'Start Row        ' 1 = column A, 2= B
    
    StrRw = StrRw - 1
    StrCl = StrCl - 1
    'Addjust Des Num with increaing text and comma
    DesClTXT = Split("#, Desc , Desc2 ,  Refrenace No.  ,Desc", ",") 'Addjust Des Num with increaing text and comma
    RevSubTXT = Split("Date Sub, Date Rec ,      Days      ,Code", ",") 'Addjust Des Num with increaing text and comma
    ' note: I add space to some words for column fit like     ,      Days      ,
    
    ''DesCl = 4
    DesCl = UBound(DesClTXT) + 1
    ''RevSubTXTNum=4
    RevSubTXTNum = UBound(RevSubTXT) + 1
    TotalCl = DesCl + (RevNum * RevSubTXTNum)
    N = 0
        For Rw = 1 + StrRw To Rws + 3 + StrRw 'Rows + Table Titel Rows
            For CL = 1 To ((TotalCl + 1) + 3) ' des + Rev +Remarks
                With Cells(Rw, StrCl + CL)
                If Rw < (Rws + 3 + StrRw) Then


                    If Rw - StrRw = 1 Then ' First Row of Main Table
                        If CL <= DesCl Then
                            .Resize(2, 1).Merge
                            .Value = DesClTXT(CL - 1)
                        ElseIf CL = (TotalCl + 1) Then
                            .Resize(2, 1).Merge
                            .Value = "          Remarks          "
                        ElseIf (CL > DesCl And CL <= (TotalCl)) And (CL - (DesCl + 1)) Mod RevSubTXTNum = 0 Then
                            .Resize(1, RevSubTXTNum).Merge
                            .Value = "Rev" & N
                            N = N + 1
                        End If
                      Cells.EntireColumn.AutoFit
                    ElseIf Rw - StrRw = 2 Then ' First Row of Main Table
                    If (CL > DesCl And CL <= (TotalCl)) And (CL - (DesCl + 1)) Mod RevSubTXTNum = 0 Then .Resize(1, RevSubTXTNum) = RevSubTXT
                    ElseIf CL <= (TotalCl) Then
                    '.Value = CL
                    ElseIf CL = ((TotalCl) + 1 + 1) Then
                    TXT = ""
                        
                        For i = StrCl + 1 To (StrCl + DesCl - 0)
                        With Cells(Rw, i)
                        TXT = TXT & IIf(TXT <> "", ",", "") & .Address(False, False) & IIf(i <> (StrCl + DesCl - 0), "," & """,""", "")
                        End With
                        Next
                       TXT = "=IF(COUNTA(" & Cells(.Row, (StrCl + 1)).Address & ":" & Cells(.Row, (StrCl + DesCl)).Address & ")<>0," & "CONCATENATE(" & TXT & ")" & ","""")"
                         .Value = TXT
                    ElseIf CL = ((TotalCl) + 1 + 2) Then
                    TXT = ""
                       For x = 1 To 3
                       DevCL = StrCl + DesCl + ((x - 1) * RevSubTXTNum)
                       MyRange = Cells(.Row, (DevCL + 1)).Address & ":" & Cells(.Row, (DevCL + RevSubTXTNum)).Address(False, False)
                        TXT = TXT & IIf(TXT <> "", "&", "") & "IF(COUNTA(" & MyRange & ")<>0," & """|""&CONCATENATE("
                            For i = (DevCL + 1) To (DevCL + RevSubTXTNum)
                                With Cells(Rw, i)
                                 RevTite = Cells(StrRw + 1, .Column).Address(False, False)
                                If i = (DevCL + 1) Or i = (DevCL + 2) Then 'For Date Format
                                 MyCell = .Address(False, False)
                                 
                                TXT = TXT & IIf(TXT <> "", IIf(i = (DevCL + 1), RevTite & "," & """,""", "") & ",", "") & "TEXT(" & MyCell & ",""dd-mmm-yy"")" & IIf(i <> (DesCl - 0), "," & """,""", "")
                                Else
                                MyCell = .Address(False, False)
                               
                                TXT = TXT & IIf(TXT <> "", IIf(i = (DevCL + 1), RevTite & "," & """,""", "") & ",", "") & MyCell & IIf(i <> (DesCl - 0), "," & """,""", "")
                                End If
                                End With
                            Next
                            TXT = TXT & ")&"";"","""")"


                        Next
                         .Value = "=" & TXT
                    ElseIf CL = ((TotalCl) + 1 + 3) Then
                     TXT = ""
                     MyCell = .Cells(1, -1).Address(False, False)
                     TXT = "=SUBSTITUTE(" & .Cells(1, 0).Address(False, False) & ",""|""," & MyCell & "&"","")"
                     .Value = "" & TXT
                    


                    End If
                    
                Else
                    If CL = ((TotalCl) + 1 + 1) Then
                    .Resize(1, 3).EntireColumn.Hidden = True
                    ElseIf CL = ((TotalCl) + 1 + 3) Then
                    TXT = ""
                    For i = 1 To Rws
                    TXT = TXT & IIf(TXT <> "", ",", "") & Cells(StrRw + i + 2, .Column).Address(False, False)
                    Next
                    .Value = "" & "=CONCATENATE(" & TXT & ")"
                    End If
                    
                End If
                    
                End With
            Next
        Next
        With Cells(StrRw + 1, StrCl + 1)
                With .Resize(2, ((TotalCl) + 1))
                    With .Interior
                        .Pattern = xlSolid
                        .Color = RGB(253, 233, 217)
                    End With
                End With
                
                With .Resize(Rws + 2, ((TotalCl) + 1))
                    .HorizontalAlignment = xlCenter
                    .VerticalAlignment = xlCenter
                
                   For B = 7 To 12
                        With .Borders(B)
                            .LineStyle = xlContinuous
                            .ColorIndex = 0
                            .TintAndShade = 0
                            .Weight = xlHairline
                        End With
                    Next
                  'c = StrCl + TotalCl + 1
                ' Cells(1, 1).Resize(1, c).EntireColumn.AutoFit
                   
                   ' Columns("A:" & Chr(((TotalCl) + 1) + 64)).EntireColumn.AutoFit
                End With
        End With




    Range(Cells(StrRw + Rws + 6, StrCl + 1).Resize((Rws * RevNum) + 4, 10).Address).FormulaArray = "=TRIM(MID(SUBSTITUTE(TRIM(MID(SUBSTITUTE(" & Cells(StrRw + Rws + 3, StrCl + ((TotalCl) + 1 + 3)).Address(False, False) & ","";"",REPT("" "",999))" & _
    ",(ROW()-ROW(" & Cells(StrRw + Rws + 6, StrCl + 1).Address(False, False) & ")+1)*999-998,999)),"","",REPT("" "",999)),(COLUMN()-COLUMN(" & Cells(StrRw + Rws + 6, StrCl + 1).Address(False, False) & ")+1)*999-998,999))"


    With Cells(StrRw + Rws + 5, StrCl + 1)
                With .Resize(1, 12)
                    With .Interior
                        .Pattern = xlSolid
                        .Color = RGB(253, 233, 217)
                    End With
                End With
                
    
                With .Resize((Rws * RevNum) + 5, 12)
                    .HorizontalAlignment = xlCenter
                    .VerticalAlignment = xlCenter
                
                   For B = 7 To 12
                        With .Borders(B)
                            .LineStyle = xlContinuous
                            .ColorIndex = 0
                            .TintAndShade = 0
                            .Weight = xlHairline
                        End With
                    Next
                End With
    
    End With
    
    Application.ScreenUpdating = True
    
End Sub
 
Upvote 0
Yongle said:
Can you run this to see if it finds the correct cells (can narrow down range to make it more robust later)
- assumes space exists between Rev and number

Code: 
Sub Test()
    Dim c As Long, myStr As String, cel As Range, FindWhat As String
    On Error Resume Next
    For c = 0 To 10
        FindWhat = "Rev " & c
        addr = ""
        addr = ActiveSheet.Cells.Find(FindWhat).Address(0, 0)
        If Not addr = vbNullString Then myStr = myStr & vbCr & FindWhat & vbTab & addr
    Next c
        FindWhat = "Remarks"
        addr = ""
        addr = ActiveSheet.Cells.Find(FindWhat).Address(0, 0)
        If Not addr = vbNullString Then myStr = myStr & vbCr & FindWhat & vbTab & addr
    MsgBox myStr
End Sub



Have you considered creating your table to include all 8 revisions and hiding the ones you do not want?
- "Remarks" would always be in the same place
- hiding and unhiding could be automated
- much simpler to code
Click to expand...

hi Yongle,

Sorry for the late reply been busy lately.

I tried the code above and make some hidden column to have a fixed position of the remarks.

It reads Remarks is in AX13

My Column is up to AX and the data start in row I16

Thank you for the reply
 
Last edited:
Upvote 0
Hi Dossfm0q,

Thank for your for your reply i tried your code and its very complex and its hard for me to understand and im still new in excel VBA.

Thank you again
 
Upvote 0
So do you want any more help?
- if so, which way do you want to go

Unfortunately, I am now occupied for a few days - will get back to this thread when I can
 
Upvote 0
Yes, I will stick in your code its easy for me to understand.

No problem I'll wait.

Thank you for your help.
 
Upvote 0
You must log in or register to reply here.

Similar threads

C
  • Question Question
Transpose multiple columns to a single column
Replies
1
Views
69
Fluff
Fluff
J
  • Locked
  • Question Question
Change setup to vertical
Replies
1
Views
125
Peter_SSs
Peter_SSs
M
  • Question Question
Transpose data from table to calendar
Replies
1
Views
284
bobaol
B
W
  • Question Question
How to copy paste date wise horizontal employee attendance vertically
Replies
4
Views
226
WasimK
W
D
  • Solved
Position UserForm Relative to Cell
Replies
4
Views
512
Domenic
D

Forum statistics

Threads
1,223,911
Messages
6,175,323
Members
452,635
Latest member
laura12345

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