Extract, Transpose and Fill automation in a survey

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