December’s Course of the Month is now available! Enroll to learn ITIL® Foundation best practices for delivering IT services effectively and efficiently.
Sub x()
Dim r As Range, n As Long, i, j As Long, c As Long, v
v = Array(5, 5, 4, 4, 4, 4, 5) 'number of options for each question
With Sheets("Sample")
.Range("A2", .Range("A" & Rows.Count).End(xlUp)).Copy Sheets("OutputExample").Range("A2")
For n = 2 To .Range("A" & Rows.Count).End(xlUp).Row
Set r = .Cells(n, 2).Resize(, v(j))
c = 1
Do While Not IsEmpty(r(1))
i = Application.Match(1, r, 0)
c = c + 1
If IsNumeric(i) Then
Sheets("OutputExample").Cells(Rows.Count, c).End(xlUp)(2) = Left(r(1).Offset(1 - n, i - 1), 1)
Else
Sheets("OutputExample").Cells(Rows.Count, c).End(xlUp)(2) = 0
End If
Set r = r.Offset(, v(j))
j = j + 1
Loop
j = 0
Next n
End With
With Sheets("OutputExample")
With .Range("B2", .Range("B2").End(xlToRight)).Offset(-1)
.Formula = "=""Q"" & column()-1"
.Value = .Value
End With
End With
End Sub
If you are experiencing a similar issue, please ask a related question
Join the community of 500,000 technology professionals and ask your questions.