Extract, Transpose and Fill automation in a survey

[Renczi]

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.

[Admin]

Hi

Welcome to board!!

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


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

[Renczi]

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.

[Admin]

Hi

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


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

[Renczi]

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

[Renczi]

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.

[Admin]

Hi

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

with


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

[Renczi]

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

[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.

[Renczi]

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.