I added the columns with the red text.
With the macro below to rearange the data.
After that a pivot table.
See the attached file for the result in the sheet Output (of the sheet ACTUAL).
Sub CONVERTROWSTOCOL_Oeldere_revisted_new()
Dim rsht1 As Long, rsht2 As Long, i As Long, col As Long, wsTest As Worksheet, mr As Worksheet, ms As Worksheet
'check if sheet "ouput" already exist
Const strSheetName As String = "Output"
Set wsTest = Nothing
On Error Resume Next
Set wsTest = ActiveWorkbook.Worksheets(strSheetName)
On Error GoTo 0
If wsTest Is Nothing Then
Worksheets.Add.Name = strSheetName
End If
'set the data
Set mr = Sheets("ACTUAL") 'this is the name of the source sheet
Set ms = Sheets("Output") 'this is the name of the destiny sheet
col = 3
'End set the data
With ms
.UsedRange.ClearContents
.Range("A1:D1").Value = Array("Name", "Choise", "date", "value")
End With
rsht2 = ms.Range("A" & Rows.Count).End(xlUp).Row
With mr
rsht1 = .Range("A" & .Rows.Count).End(xlUp).Row
For i = 2 To rsht1
Do While .Cells(1, col).Value <> "" 'And .Cells(I, col).Value <> ""
rsht2 = rsht2 + 1
ms.Range("A" & rsht2).Value = .Range("A" & i).Value
ms.Range("B" & rsht2).Value = .Range("B" & i).Value
ms.Range("C" & rsht2).Value = .Cells(1, col).Value
ms.Range("D" & rsht2).Value = .Cells(i, col).Value
col = col + 1
Loop
col = 3
Next
End With
With ms
.Range("B2:B" & .Rows.Count).SpecialCells(4).EntireRow.Delete
.Columns("A:Z").EntireColumn.AutoFit
End With
End Sub
Bookmarks