Transposing data

[ark123]

Hello I have landmark data that is formatted like this:

Individual	Landmark	x	y	z
2​	1​	72.90780000​	186.51930000​	-278.35570000​
2​	2​	82.24020000​	149.18470000​	-318.74440000​
2​	3​	70.94750000​	157.98370000​	-337.20170000​
2​	4​	75.31240000​	156.86200000​	-328.62120000​
2​	5​	65.41960000​	161.88890000​	-346.20200000​
2​	6​	41.34960000​	158.41210000​	-346.51680000​
2​	7​	45.85400000​	195.35400000​	-341.91670000​
2​	8​	31.12320000​	212.50090000​	-317.48140000​

And I am trying to figure out how to transpose it to this, without having to copy and paste each one:

Individual	1x	1y	1z	2x	2y	2z	3x	3y	3z
2​	72.90780000​	186.51930000​	-278.35570000​	82.24020000​	149.18470000​	-318.74440000​	70.94750000​	157.98370000​	-337.20170000​

I cannot for the life of me figure out an easy way to do this. Thanks in advance!

 

[mumps]

Will you have more than one individual? Will you have more than 3 columns of data to transpose?

 

[ark123]

Yes, there are about 1000 individuals total. The only 3 columns that will need to be transposed are the x,y,z for each of the 34 landmarks per individual

The software I am using to calculate interlandmark distances requires one individual per row rather than how the data exported from the 3D point collection software.

 

[mumps]

Try:

Sub TransposeData()
    Application.ScreenUpdating = False
    Dim LastRow As Long, FirstVisRow As Long, lCol As Long, RngList As Object, key As Variant, LM As Range, x As Long: x = 1
    LastRow = Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    Set RngList = CreateObject("Scripting.Dictionary")
    lCol = Cells(1, Columns.Count).End(xlToLeft).Column + 1
    For x = 1 To 34
        Cells(1, lCol).Resize(, 3) = Array(x & "x", x & "y", x & "z")
        lCol = Cells(1, Columns.Count).End(xlToLeft).Column + 1
    Next x
    For Each Rng In Range("A2:A" & LastRow)
        If Not RngList.Exists(Rng.Value) Then
            RngList.Add Rng.Value, Nothing
        End If
    Next
    For Each key In RngList
        With Cells(1, 1).CurrentRegion
            .AutoFilter 1, key
            FirstVisRow = Range("A2", Cells(Rows.Count, "A").End(xlUp)).SpecialCells(xlCellTypeVisible).Cells(1, 1).Row
            For Each LM In Range("B2:B" & LastRow).SpecialCells(xlCellTypeVisible)
                lCol = Cells(FirstVisRow, Columns.Count).End(xlToLeft).Column + 1
                Cells(FirstVisRow, lCol).Resize(, 3).Value = LM.Offset(, 1).Resize(, 3).Value
            Next LM
            Rows(FirstVisRow + 1).Resize(33).Delete
        End With
    Next key
    Range("A1").AutoFilter
    Range("B:E").EntireColumn.Delete
    Columns.AutoFit
    Application.ScreenUpdating = True
End Sub

The macro assumes the following:

34 landmarks per individual