Transpose horizontal data to vertical data with automatic update

nathanmav

Board Regular
Joined
Dec 11, 2012
Messages
82
Hi,

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

[/URL] url picture[/IMG]
 
Last edited:

Yongle

Well-known Member
Joined
Mar 11, 2015
Messages
4,623
Office Version
365
Platform
Windows
Try this in a copy of your workbook

Amend the name for sheet1 if different
Amend A3 to the reference of the first cell with data in the first row with data (NOT headings)
Hopefully VBA below tabulates your data as requested
Results are created in a new sheet

Place in a standard module
Code:
Sub ReshapeData()
    Const FirstCell = "[COLOR=#ff0000][I]A3[/I][/COLOR]"
    Const SheetName = "[COLOR=#ff0000][I]Sheet1[/I][/COLOR]"
    
    Dim ws1 As Worksheet, ws2 As Worksheet, c1 As Range, cel As Range
    Dim r As Long, row1 As Long, LastR As Long, r2 As Long, Rev  As Long, c As Long, colm1 As Long
    Set ws1 = Sheets(SheetName)
    Set ws2 = Sheets.Add(before:=Sheets(1))
    Set c1 = ws1.Range(FirstCell)
    row1 = c1.Row
    colm1 = c1.Column
    LastR = ws1.Cells(Rows.Count, c1.Column).End(xlUp).Row
[COLOR=#006400][I]'headers[/I][/COLOR]
    ws2.Cells(1, 1).Resize(, 11) = Split("#,desc,desc2,Reference no.,Disc,Revision,Date Sub,Date Rec,Days,Code,REMARKS", ",")
    
        For r = row1 To LastR
[COLOR=#006400][I]'first 5 columns[/I][/COLOR]
            r2 = ws2.Cells(Rows.Count, 1).End(xlUp).Row + 1
            ws1.Cells(r, 1).Resize(, 5).Copy ws2.Cells(r2, 1)
[COLOR=#006400][I]'add revisions[/I][/COLOR]
            For Rev = 0 To 5
                c = (colm1 + 5) + (Rev * 4)
                    If ws1.Cells(r, c) > 0 Then
                        If Rev > 0 Then
                            Set cel = ws2.Cells(r2, 1)
                            cel.Resize(, 5).Copy cel.Offset(1)
                            r2 = r2 + 1
                        End If
                        
                        ws2.Cells(r2, "F") = Rev
                        ws1.Cells(r, c).Resize(, 4).Copy ws2.Cells(r2, "G")
[COLOR=#006400][I]'add remarks[/I][/COLOR]
                        ws1.Cells(r, colm1 + 29).Copy ws2.Cells(r2, "K")
                    End If
            Next Rev
        Next r
[COLOR=#006400]'basic formatting (amend to suit your own requirements)[/COLOR]
        With ws2
            .Cells(1, 1).CurrentRegion.Borders.LineStyle = xlContinuous
            With .Columns("G:H")
                .ColumnWidth = 15
                .HorizontalAlignment = xlCenter
            End With
            
        End With
End Sub
To amend the formatting to the way you want, try recording a macro when you do that manually
- the recorded macro should provide you with the correct syntax (but with static cell references)
- amend that to work dynamically as required
 
Last edited:

nathanmav

Board Regular
Joined
Dec 11, 2012
Messages
82
hi Yongle,

Thank you for the reply.

I tried the formula but there is some problem the 'first 5 columns is not showing.

Thank you again
 

Yongle

Well-known Member
Joined
Mar 11, 2015
Messages
4,623
Office Version
365
Platform
Windows
I will amend my worksheet to match yours and update the code after testing

Which is the first cell with data (not the header)?
Which column is remarks?
Which is first header row?
 
Last edited:

nathanmav

Board Regular
Joined
Dec 11, 2012
Messages
82
In my original file the data will start in "Column I row 16" and remarks will be in "Column AP".

is there a way to attach excel file so that its easy to explain when you see my sample.

https://imgur.com/a/OybcIUx

 
Last edited:

Yongle

Well-known Member
Joined
Mar 11, 2015
Messages
4,623
Office Version
365
Platform
Windows
is there a way to attach excel file so that its easy to explain when you see my sample.
Hopefully no need for your workbook
- will post updated code later today when back at PC
 

Yongle

Well-known Member
Joined
Mar 11, 2015
Messages
4,623
Office Version
365
Platform
Windows
As it happens my original code would not have worked with column I as starting point
because this line
Code:
ws1.Cells(r, 1).Resize(, 5).Copy ws2.Cells(r2, 1)
should be corrected to
Code:
ws1.Cells(r, colm1).Resize(, 5).Copy ws2.Cells(r2, 1)
But you have also inserted 4 extra columns (when post#5 image is checked against post#1 image) :confused:
- Plan (column N)
- App (Column O)
- 2 blank columns to left of Remarks (columns AN & AO)

Please specify EXACTLY what the starting point is and what flexibility you need
- VBA is not like Excel
- it does not re-rereference cells automatically
- if you tell it to do something to cell P25 that is what it will do

VBA can search for column Headers to determine which column to copy - but your merged cells may cause a few difficulties
Does the data always start in column I, always in row 16


thanks
 
Last edited:

nathanmav

Board Regular
Joined
Dec 11, 2012
Messages
82
Yes it will always start in Column I row 16
I need to insert additional columns if i have more than five revisions the minimum is up to revision 5 but there are times that it will go up to revision 8 so the problem is how can I specify the exact location for the remarks column.
I will insert that additional column after column AM.

But the code is now working and i add this code
Code:
                        ws2.Cells(r2, "H") = Rev                        
                        ws2.Columns("H").NumberFormat = "General"
                        
                        ws1.Cells(r, c).Resize(, 4).Copy ws2.Cells(r2, "I")
                        ws2.Columns("I").NumberFormat = "[$-409]d-mmm-yy;@"
to have custom format.

Thank you
 
Last edited:

Yongle

Well-known Member
Joined
Mar 11, 2015
Messages
4,623
Office Version
365
Platform
Windows
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
I need to insert additional columns if i have more than five revisions the minimum is up to revision 5 but there are times that it will go up to revision 8 so the problem is how can I specify the exact location for the remarks column.
I will insert that additional column after column AM.
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
 
Last edited:

Dossfm0q

Board Regular
Joined
Mar 9, 2009
Messages
187
Greetings All PLS TRY this with Test it is OK but need perfect One to do some touch

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

[SIZE=4][B][COLOR=#ff0000]'''' Here need you to do some touch[/COLOR][/B][/SIZE]
[B8] = "=CONCATENATE(B4,"","",C4,"","",D4,"","",E4)"
[C8] = "=IF(F4<>"""",""*""&CONCATENATE(TEXT(F4,""dd-mmm-yy""),"","",TEXT(G4,""dd-mmm-yy""),"","",H4,"","",I4)&"";"","""")&IF(J4<>"""",""*""&CONCATENATE(TEXT(J4,""dd-mmm-yy""),"","",TEXT(K4,""dd-mmm-yy""),"","",L4,"","",M4)&"";"","""") &IF(N4<>"""",""*""&CONCATENATE(TEXT(N4,""dd-mmm-yy""),"","",TEXT(O4,""dd-mmm-yy""),"","",P4,"","",Q4)&"";"","""")&IF(R4<>"""",""*""&CONCATENATE(TEXT(R4,""dd-mmm-yy""),"","",TEXT(S4,""dd-mmm-yy""),"","",T4,"","",U4)&"";"","""") &IF(V4<>"""",""*""&CONCATENATE(TEXT(V4,""dd-mmm-yy""),"","",TEXT(W4,""dd-mmm-yy""),"","",X4,"","",Y4)&"";"","""")&IF(Z4<>"""",""*""&CONCATENATE(TEXT(Z4,""dd-mmm-yy""),"","",TEXT(AA4,""dd-mmm-yy""),"","",AB4,"","",AC4)&"";"","""")"
[B9] = "=CONCATENATE(B5,"","",C5,"","",D5,"","",E5)"
[C9] = "=IF(F5<>"""",""*""&CONCATENATE(TEXT(F5,""dd-mmm-yy""),"","",TEXT(G5,""dd-mmm-yy""),"","",H5,"","",I5)&"";"","""")&IF(J5<>"""",""*""&CONCATENATE(TEXT(J5,""dd-mmm-yy""),"","",TEXT(K5,""dd-mmm-yy""),"","",L5,"","",M5)&"";"","""") &IF(N5<>"""",""*""&CONCATENATE(TEXT(N5,""dd-mmm-yy""),"","",TEXT(O5,""dd-mmm-yy""),"","",P5,"","",Q5)&"";"","""")&IF(R5<>"""",""*""&CONCATENATE(TEXT(R5,""dd-mmm-yy""),"","",TEXT(S5,""dd-mmm-yy""),"","",T5,"","",U5)&"";"","""") &IF(V5<>"""",""*""&CONCATENATE(TEXT(V5,""dd-mmm-yy""),"","",TEXT(W5,""dd-mmm-yy""),"","",X5,"","",Y5)&"";"","""")&IF(Z5<>"""",""*""&CONCATENATE(TEXT(Z5,""dd-mmm-yy""),"","",TEXT(AA5,""dd-mmm-yy""),"","",AB5,"","",AC5)&"";"","""")"


[B11] = "=SUBSTITUTE(C8,""*"",B8&"","")"
[B12] = "=SUBSTITUTE(C9,""*"",B9&"","")"


[B14] = "=CONCATENATE(B11,B12)"
''''''''''''''''''''''''''''''''''''''''''''
On Error Resume Next ' may it Long not work
    Range("B16:L40").FormulaArray = "=TRIM(MID(SUBSTITUTE(IFERROR(MID(B$14,FIND(""|"",SUBSTITUTE("";""&B$14&"";"","";"",""|"",(ROW()-ROW(B$16)+1))),FIND("";"",B$14&"";"",FIND(""|"",SUBSTITUTE("";""&B$14&"";"","";"",""|"",(ROW()-ROW(B$16)+1))))-FIND(""|"",SUBSTITUTE("";""&B$14&"";"","";"",""|"",(ROW()-ROW(B$16)+1)))),""""),"","",REPT("" "",99)),(COLUMN()-COLUMN(B$16)+1)*99-98,99))"
On Error GoTo 0
'''''''''''''''''''' workwill
    Range("B16:L40").FormulaArray = "=TRIM(MID(SUBSTITUTE(TRIM(MID(SUBSTITUTE(B14,"";"",REPT("" "",999)),(ROW()-ROW(B$16)+1)*999-998,999)),"","",REPT("" "",999)),(COLUMN()-COLUMN(B$16)+1)*999-998,999))"
'COLOR
With Cells(15, 1).Resize(1, 10)
    With .Interior
        .Pattern = xlSolid
        .Color = RGB(253, 233, 217)
    End With
End With
'Borders


With Cells(15, 1).Resize(15, 10)
        .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:

Forum statistics

Threads
1,081,513
Messages
5,359,225
Members
400,521
Latest member
smarty1995

Some videos you may like

This Week's Hot Topics

  • VBA (Userform)
    Hi All, I just would like to know why my code isn't working. Here is my VBA code: [CODE=vba]Private Sub OKButton_Click() Dim i As Integer...
  • List box that changes fill color
    Hello, I have gone through so many pages trying to figure this out. I have a 2020 calendar that depending on the day needs to have a certain...
  • Remove duplicates and retain one. Cross-linked cases
    Hi all I ran out of google keywords to use and still couldn't find a reference how to achieve the results of a single count. It would be great if...
  • VBA Copy and Paste With Duplicates
    Hello All, I'm in need of some input. My VBA skills are sub-par at best. I've assembled this code from basic research and it works but is...
  • Macro
    is it possible for a macro to run if the active cell value is different to the value above it
  • IF DATE and TIME
    I currently use this to check if date has passed but i also need to set a time on it too. Is it possible? [CODE=vba]=IF(B:B>TODAY(),"Not...
Top