Extract, Transpose and Fill automation in a survey

Dear friends,
With the help of fellow forum colleagues I managed to convert the output of a 300 people Google survey to something processable in Excel. Essentially, transforming the layout of the "per-row" output into a "per-column" table that I can Pivot or analyze afterwards.
But I cannot complete a piece of the layout without your help.
I've attached a sample of the survey (just 2 people/34 questions due to file size limits in this forum) and explained what I need within the spreadsheet.
In a nutshell, I need to make 4 new columns, copy the values of the last 4 questions of each respondent to the corresponding column and fill the rest of the column down until the next respondent values begin.
This is because this last four questions hold demographic data (Job post, Area, Years in the job, Comments) that I will need to group the respondent answers when I process them in a pivot table or statistical package.

Hi

Welcome to board!!

Insert a standard module and put the code there. Adjust the range wherever necessary.

Code:

---

Option Explicit

Sub kTest()
   
    Dim Data, i As Long, n As Long, c As Long, dic As Object
    Dim arrOutput(), List, v, ShtOutput As Worksheet
   
    Set dic = CreateObject("scripting.dictionary")
        dic.comparemode = 1
   
    Data = Worksheets("form responses").Range("a1").CurrentRegion.Resize(, 35).Value2
    List = Worksheets("sheet2").Range("a7:g40").Value2 '<< adjust this range
   
    For i = 1 To UBound(List, 1)
        dic.Item(List(i, 1)) = Array(List(i, 7), List(i, 2))
    Next
   
    ReDim arrOutput(1 To UBound(Data, 2) * 34, 1 To 10)
   
    For i = 2 To UBound(Data, 1)
        For c = 2 To UBound(Data, 2) - 4
            n = n + 1
            arrOutput(n, 1) = Data(i, 1)
            arrOutput(n, 2) = c - 1
            arrOutput(n, 3) = Data(i, c)
            arrOutput(n, 4) = Evaluate("=LOOKUP(""" & Left$(Data(i, c), 1) & """,{""a"",1;""b"",2;""c"",3;""d"",4;""e"",5;""f"",0})")
            v = dic.Item(c - 1)
            arrOutput(n, 5) = v(0)
            arrOutput(n, 6) = v(1)
            arrOutput(n, 7) = Data(i, 32)
            arrOutput(n, 8) = Data(i, 33)
            arrOutput(n, 9) = Data(i, 34)
            arrOutput(n, 10) = Data(i, 35)
        Next
    Next
   
    On Error Resume Next
    Set ShtOutput = Worksheets("Output")
    If Err.Number <> 0 Then
        Set ShtOutput = Worksheets.Add
        ShtOutput.Name = "Output"
    End If
    Err.Clear: On Error GoTo 0
   
    With ShtOutput
        .Range("a1:j1") = [{"Nombre","Pregunta","Respuesta","Valor","Clasificacion","Tema","Puesto","Area","Antigüedad","Comentario"}]
        .Range("a2").Resize(n, 10).Value2 = arrOutput
    End With
   
End Sub

---

Wow! That was fast! I included the code in my Personal.xlsb sheet and run it on the file I sent to you. I stops at an error message that I uploaded in this message:"subscript out of range". I also included the debug screen.
I was trying the understand the logic and it is still challenging for me to decipher some of the limits of the variables or arrays (i, c, n, etc.). I understand, for example, that in the line:"List = Worksheets("sheet2").Range("a7:g40").Value2 '<< adjust this range", as far as the data is in the exact same range as you saw in my file, it's ok. Right?
Anyway, I'm most hopeful I will tackle this survey processing and if you would like to assist me a bit more I'd be most grateful.

Hi

If you are running this code from the Personal.xlsb, try this version.

Code:

---

Option Explicit

Sub kTest()
   
    Dim Data, i As Long, n As Long, c As Long, dic As Object
    Dim arrOutput(), List, v, ShtOutput As Worksheet
   
    Set dic = CreateObject("scripting.dictionary")
        dic.comparemode = 1
   
    Data = ActiveWorkbook.Worksheets("form responses").Range("a1").CurrentRegion.Resize(, 35).Value2
    List = ActiveWorkbook.Worksheets("sheet2").Range("a7:g40").Value2 '<< adjust this range
   
    For i = 1 To UBound(List, 1)
        dic.Item(List(i, 1)) = Array(List(i, 7), List(i, 2))
    Next
   
    ReDim arrOutput(1 To UBound(Data, 2) * 35, 1 To 10)
   
    For i = 2 To UBound(Data, 1)
        For c = 2 To UBound(Data, 2) - 4
            n = n + 1
            arrOutput(n, 1) = Data(i, 1)
            arrOutput(n, 2) = c - 1
            arrOutput(n, 3) = Data(i, c)
            arrOutput(n, 4) = Evaluate("=LOOKUP(""" & Left$(Data(i, c), 1) & """,{""a"",1;""b"",2;""c"",3;""d"",4;""e"",5;""f"",0})")
            v = dic.Item(c - 1)
            arrOutput(n, 5) = v(0)
            arrOutput(n, 6) = v(1)
            arrOutput(n, 7) = Data(i, 32)
            arrOutput(n, 8) = Data(i, 33)
            arrOutput(n, 9) = Data(i, 34)
            arrOutput(n, 10) = Data(i, 35)
        Next
    Next
   
    On Error Resume Next
    Set ShtOutput = ActiveWorkbook.Worksheets("Output")
    If Err.Number <> 0 Then
        Set ShtOutput = ActiveWorkbook.Worksheets.Add
        ShtOutput.Name = "Output"
    End If
    Err.Clear: On Error GoTo 0
   
    With ShtOutput
        .Range("a1:j1") = [{"Nombre","Pregunta","Respuesta","Valor","Clasificacion","Tema","Puesto","Area","Antigüedad","Comentario"}]
        .Range("a2").Resize(n, 10).Value2 = arrOutput
        .Range("a2").Resize(n, 10).WrapText = False
    End With
   
End Sub

---

Success! I attached the worksheet in case you find it useful for something else. Thank you so much!

Hi there! Despite my happiness in my previous mail, when I came to process the actual survey data (147 rows, 35 columns) I got a "subscript out of range" message that I couldn´t decipher.
I managed to attach my spreadsheet and a screen capture of the debug page in vba.
I would greatly appreciate your help to figure out what's going on.
Best regards.

Hi

Replace

Code:

---

ReDim arrOutput(1 To UBound(Data, 2) * 35, 1 To 10)

---

with

Code:

---

ReDim arrOutput(1 To UBound(Data, 1) * 35, 1 To 10)

---

Now it did the job! You just helped me be on track with my task. Deeply grateful!

Hey "Renczi" Your survey related discussion really very important. Actually If you need any useful data about the survey so you can communication with us.

Quote:

---

Originally Posted by johnabrahaml

Hey "Renczi" Your survey related discussion really very important. Actually If you need any useful data about the survey so you can communication with us.

---

Not sure if you need me to do something else.