Transpose horizontal data to vertical data with automatic update

[nathanmav]

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]

 

[Yongle]

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

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

 

[nathanmav]

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]

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?

 

[nathanmav]

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

 

[Yongle]

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]

As it happens my original code would not have worked with column I as starting point
because this line

ws1.Cells(r, 1).Resize(, 5).Copy ws2.Cells(r2, 1)

should be corrected to

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)
- 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

 

[nathanmav]

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

                        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

 

[Yongle]

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

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

 

[Dossfm0q]

Greetings All PLS TRY this with Test it is OK but need perfect One to do some touch

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