I need to transform the Excel spreadsheet described below. What code would I use?

This question is a variation on a couple of similar questions I posted recently.
I have attached an Excel 2007 spreadsheet (Sample) that contains a small sample of a larger output file.
Another sheet is included with the expected output.

These data represent 4 subjects (Column A) who answered 7 questions. Questions 1,2, & 7 have 5 possible answers numbered  5,4,3,2,1 represented in columns B:K (Q 1-2), AB:AF (Q7) in Row 1. Questions 3 - 6 have 4 possible answers numbered 1 - 4 (Q3,4,5) and 4,3,2,1 (Q6) in columns L:AA in row 1. PLEASE NOTE: Questions 1 and 3 have text included in the answer in addition to the number in Row 1.

Each subject chose 1 of the 5 answers for Q 1-2, 7 and chose one of the 4 answers for Q 3-6.  The answer they chose is marked in that subject's row under the appropriate column with a 1. I need code that would transform each answer into the actual numerical choice shown in the same column in Row 1.
This number should be  displayed  in the appropriate Subject's Row under the column names for each question -Q1 – Q7 (See Output Sheet).  

Who is Participating?
StephenJRConnect With a Mentor Commented:
Another variation on a theme. This will only work if the question codes are single-digit (e.g. 1-9) but it could be changed if this were not always the case:
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)
                Sheets("OutputExample").Cells(Rows.Count, c).End(xlUp)(2) = 0
            End If
            Set r = r.Offset(, v(j))
            j = j + 1
        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

Open in new window

PDSWSSAuthor Commented:
Brilliant. You are a whiz. Saved me a lot of time. Thank you very, very much.

The subject IDs did not appear in column A. But this is trivial. No need to spend any more time.

Have a great weekend.  
PDSWSSAuthor Commented:
Brilliant answers and thanks again.

Question has a verified solution.

Are you are experiencing a similar issue? Get a personalized answer when you ask a related question.

Have a better answer? Share it in a comment.

All Courses

From novice to tech pro — start learning today.