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

Pivot Table Drill Down
Double-click any number in a pivot table to create a new report showing all detail rows that make up that number
@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

R
  • Question
Adding Multiple Vertical Lines on Horizontal Bar Chart
Replies
1
Views
196
NdNoviceHlp
NdNoviceHlp
C
  • Question
Excel formula to dynamically reference a range using values from a horizontally and vertically spilled ranges
Replies
1
Views
508
cadams1979
C
S
  • Question
Time on X axis, and Dates on Y axis
Replies
1
Views
55
rlv01
R
K
  • Solved
Update to existing Move data macro
2
Replies
11
Views
272
Alex Blakenburg
A
S
  • Solved
INDIRECT Vertical Auto-Fill
Replies
4
Views
467
stuartjohnwood
S

Forum statistics

Threads
1,214,832
Messages
6,121,844
Members
449,051
Latest member
excelquestion515

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