transpose cross table to list

[Stefan_Sand]

hi all,

i have a projectsheet, containing relevant project data. i want to transpose this table into list form to get out the planned personal effort per person on the phases.

The basic data are in Projektplan Test sheet - > i marked the data with the corresponding colors to
the output sheet - > Output

I want to know, if it would be possible to do this in a simple way (not copy it by hand)?

Stefan

ps: please see the example sheet

[HansV]

But the number of columns in H7:V7 is not equal to the number of rows in B8:B16 so the lengths of the columns in the Output sheet wouldn't be the same. Is that your intention? In the sample output, the lengths are the same.

[Don Wells]

Try the following solution:

• Select the datamatrix, H8:V16 in this instance.

• Run the Transpose macro

H.T.H.

[Stefan_Sand]

yes. there should be an entry per person per task with the amount of days.

[Stefan_Sand]

Thank You Don!

[Don Wells]

Thank You Don!

Hi Stefan
    The code you now have replaces any data on the Output sheet with the new data. The following code will make the process interactive, giving the user the choice of replacing or appending. To have the process always append, remove lines 80 through 100 from the code.

Code: Select all

Option Explicit


Public Sub Transpose()
      Dim ws As Worksheet
      Dim TR As Long ' Top Row
      Dim BR As Long ' Bottom Row
      Dim CR As Long ' Current Row
      Dim LC As Long ' Left Column
      Dim RC As Long ' Right Column
      Dim CC As Long ' Current Column
      Dim Ctr As Long

10      Set ws = Sheets("Projektplan Test")
        
20      Sheets("Projektplan Test").Activate
30      TR = Selection.Row
40      BR = TR + Selection.Rows.Count - 1
50      LC = Selection.Column
60      RC = LC + Selection.Columns.Count - 1
        
70      Sheets("Output").Select
80      If MsgBox("Do you wish to replace the existing data on the Output sheet?", _
          vbQuestion + vbYesNo, "Transpose Data") = vbYes Then
90        Range("6:" & ActiveCell.SpecialCells(xlLastCell).Row).ClearContents
100     End If
110     Ctr = Range("B" & Rows.Count).End(xlUp).Row + 1

        
120     With ws
130       For CR = TR To BR
140         For CC = LC To RC
150           If .Cells(CR, CC) <> 0 Then
160             Range("B" & Ctr) = .Range("C2")
170             Range("C" & Ctr) = .Cells(7, CC)
180             Range("D" & Ctr) = .Cells(CR, 2)
190             Range("E" & Ctr) = .Cells(CR, 3)
200             Range("F" & Ctr) = .Cells(CR, 4)
210             Range("G" & Ctr) = .Cells(CR, CC)
                
220             Ctr = Ctr + 1
230           End If
240         Next CC
250       Next CR
260     End With
        
270     Set ws = Nothing
End Sub

[Reimer]

Don,

Nice!

[Stefan_Sand]

thats pretty cool