Questionnaire (Echelle de Likert)

Bonjour,

Cette page sera découpée en 3 épisodes :

  • le questionnaire lui-même
  • la collecte des retours et l'exploitation
  • la génération du questionnaire et du système d'exploitation

Dans 2 jours, je dévoile tout (comme les

)

1- le questionnaire lui-même

Il suffit de sélectionner une des 5 cases au regard de chaque question.

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    If Intersect(Target, Range("Tableau1[[Pas d''accord]:[NSP]]")) Is Nothing Then Exit Sub
    For Each cel In Intersect(Target, Range("Tableau1[[Pas d''accord]:[NSP]]"))
        cel.Value = IIf(cel.Value = "", "X", "")
        For i = 3 To 7
            If i <> cel.Column Then Cells(cel.Row, i).ClearContents
        Next
        If cel.Value <> "" Then
            Cells(cel.Row, 8) = Cells(2, cel.Column)
        Else
            Cells(cel.Row, 8).ClearContents
        End If
    Next
End Sub
capture d ecran 619
10questionnaire.xlsm (20.82 Ko)

Bonjour ... la suite ...

2- la collecte et le traitement des informations

Les retours ayant été stockés dans un même répertoires (plus ses sous-répertoires si besoin), le fichier va récolter les réponses sans ouverture des fichiers en retour.

capture d ecran 620 capture d ecran 621
9questionnaires.zip (191.06 Ko)

La partie filtrage fait appel à un filtre avancé et renvoie les valeurs trouvées dans l'onglet d'analyse

Sub filtrer()
    Sheets("analyser").Range("J2").CurrentRegion.Offset(1, 0).ClearContents
    Sheets("data1").Range("Tdata1[#All]").AdvancedFilter Action:=xlFilterCopy, _
        CriteriaRange:=Sheets("filtre").Range("A1").CurrentRegion, CopyToRange:=Sheets("filtre").Range("A5").CurrentRegion.Resize(1), Unique:=False
    Sheets("filtre").Range("A5").CurrentRegion.Copy Destination:=Sheets("analyser").Range("J2")
End Sub

L'onglet analyse comporte une macro événementielle pour gérer les choix dans les réponses. Ici contrairement au questionnaire, il est possible de choisir plusieurs options, par exemple "d'accord" et "plutôt d'accord"

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    If Target.Count > 1 Then Exit Sub

    If Intersect(Target, Range("Tanalyse[[Pas d''accord]:[NSP]]")) Is Nothing Then Exit Sub
    For Each cel In Intersect(Target, Range("Tanalyse[[Pas d''accord]:[NSP]]"))

        cel.Value = IIf(cel.Value = "", "X", "")

        Select Case cel.Column

            Case 6
                Cells(cel.Row, 3).ClearContents
                Cells(cel.Row, 4).ClearContents
                Cells(cel.Row, 7).ClearContents
                If Cells(cel.Row, 5).Value = "" And Cells(cel.Row, 6).Value = "" Then
                    Cells(cel.Row, 8).ClearContents
                ElseIf Cells(cel.Row, 5).Value = "" Then
                    Cells(cel.Row, 8).Value = 2
                ElseIf Cells(cel.Row, 6).Value = "" Then
                    Cells(cel.Row, 8).Value = 1
                Else
                    Cells(cel.Row, 8).Value = ">0"
                End If

            Case 5
                Cells(cel.Row, 3).ClearContents
                Cells(cel.Row, 4).ClearContents
                Cells(cel.Row, 7).ClearContents
                If Cells(cel.Row, 5).Value = "" And Cells(cel.Row, 6).Value = "" Then
                    Cells(cel.Row, 8).ClearContents
                ElseIf Cells(cel.Row, 5).Value = "" Then
                    Cells(cel.Row, 8).Value = 2
                ElseIf Cells(cel.Row, 6).Value = "" Then
                    Cells(cel.Row, 8).Value = 1
                Else
                    Cells(cel.Row, 8).Value = ">0"
                End If

            Case 4
                Cells(cel.Row, 5).ClearContents
                Cells(cel.Row, 6).ClearContents
                Cells(cel.Row, 7).ClearContents
                If Cells(cel.Row, 4).Value = "" And Cells(cel.Row, 3).Value = "" Then
                    Cells(cel.Row, 8).ClearContents
                ElseIf Cells(cel.Row, 4).Value = "" Then
                    Cells(cel.Row, 8).Value = -2
                ElseIf Cells(cel.Row, 3).Value = "" Then
                    Cells(cel.Row, 8).Value = -1
                Else
                    Cells(cel.Row, 8).Value = "<0"
                End If

           Case 3
                Cells(cel.Row, 5).ClearContents
                Cells(cel.Row, 6).ClearContents
                Cells(cel.Row, 7).ClearContents
                If Cells(cel.Row, 4).Value = "" And Cells(cel.Row, 3).Value = "" Then
                    Cells(cel.Row, 8).ClearContents
                ElseIf Cells(cel.Row, 4).Value = "" Then
                    Cells(cel.Row, 8).Value = -2
                ElseIf Cells(cel.Row, 3).Value = "" Then
                    Cells(cel.Row, 8).Value = -1
                Else
                    Cells(cel.Row, 8).Value = "<0"
                End If

            Case 7
                Cells(cel.Row, 3).ClearContents
                Cells(cel.Row, 4).ClearContents
                Cells(cel.Row, 5).ClearContents
                Cells(cel.Row, 6).ClearContents
                Cells(cel.Row, 8) = 0
                If cel.Value = "" Then Cells(cel.Row, 8).ClearContents

        End Select

    Next

    filtrer

End Sub
Private Sub Worksheet_Activate()
    filtrer
End Sub

La partie compilation retourne 2 tableaux dans 2 onglets : le premier permettra le filtrage, le second produira le graphe de synthèse à partir d'un TCD

Option Explicit
    ' Mike STEELSON
    Dim data As ListObject
    Dim col As Integer, nbColonnes As Integer
    Dim cel As Range, debut As Range

Sub Lecture()
Dim repertoire As String

With Sheets("collecter les retours")

If Range("repertoire").Value = "" Then
    MsgBox "Choisir un répertoire !"
    Exit Sub
End If

    ' activation de la feuille de données
    Sheets("data1").Select
    Set data = ActiveSheet.ListObjects(1)
    If Not data.DataBodyRange Is Nothing Then data.DataBodyRange.Delete

    ' nbre de colonnes et mise en place des en-tetes de colonnes
    nbColonnes = 0
    For Each cel In .Range("debut:" & Range("debut").End(xlToRight).Address)
        data.HeaderRowRange.Cells(1, 1).Offset(0, nbColonnes) = cel.Value
        nbColonnes = nbColonnes + 1
    Next cel
    data.HeaderRowRange.Cells(1, 1).Offset(0, nbColonnes) = "Fichier source"

    ' lecture du répertoire
    ListeFichiers .Range("repertoire").Value

    ' fin du programme
    Cells.Select
    Cells.EntireColumn.AutoFit
    Cells.EntireRow.AutoFit
    Cells.Font.Underline = xlUnderlineStyleNone
    Cells(1, 1).Select
    Application.CutCopyMode = False

    ' seconde mise en forme des données
    recopier
    Sheets("synthetiser").Select

    MsgBox "Compilation des données terminée ! " & data.ListRows.Count & " lignes récupérées"

    ' enchainement sur programme spécifique si besoin

End With

End Sub

Sub ListeFichiers(repertoire As String)
Dim Fso, SourceFolder, SubFolder, fichier As Object
Set Fso = CreateObject("Scripting.FileSystemObject")
Set SourceFolder = Fso.GetFolder(repertoire)

With Sheets("collecter les retours")

    Sheets("data1").Select

    ' boucle sur tous les fichiers du répertoire
    For Each fichier In SourceFolder.Files
        If Right(fichier.Name, 4) = ".xls" Or Right(fichier.Name, 5) = ".xlsx" Or Right(fichier.Name, 5) = ".xlsm" Then
            If Left(fichier.Name, 2) <> "~$" Then

                For Each debut In .Range(.Range("debut").Offset(1, 0).Address & ":" & .Range("debut").End(xlDown).Address)
                    data.ListRows.Add
                    col = 1
                    For Each cel In .Range(debut.Address & ":" & Range(debut.Address).Offset(0, nbColonnes - 1).Address)
                        If cel.Value <> "" Then data.DataBodyRange.Cells(data.ListRows.Count, col) = " '" & repertoire & "\[" & fichier.Name & "]'!" & cel.Value & " "
                        col = col + 1
                    Next cel
                    data.DataBodyRange.Cells(data.ListRows.Count, col) = "vers ... " & fichier.Name
                    ActiveSheet.Hyperlinks.Add Anchor:=data.DataBodyRange.Cells(data.ListRows.Count, col), Address:=fichier.ParentFolder & "\" & fichier.Name
                Next debut

                ' activation de la formule en ajoutant =
                data.DataBodyRange.Select
                Selection.Replace What:=" '", Replacement:="= '", LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False
                Selection.Copy
                Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False

            End If
        End If
    Next fichier

    ' appel récursif pour les sous-répertoires
    For Each SubFolder In SourceFolder.subfolders
        ListeFichiers SubFolder.Path
    Next SubFolder

End With

End Sub

Sub select_repertoire()
    Dim repertoire As FileDialog
    Set repertoire = Application.FileDialog(msoFileDialogFolderPicker)
    repertoire.Show
    If repertoire.SelectedItems.Count > 0 Then
        Range("repertoire").Value = repertoire.SelectedItems(1)
    End If
End Sub

Sub recopier()
Dim a As ListObject, b As ListObject, i%, j%
    Set a = Sheets("data1").ListObjects(1)
    Set b = Sheets("data2").ListObjects(1)
    If Not b.DataBodyRange Is Nothing Then b.DataBodyRange.Delete
    For i = 1 To a.ListRows.Count
        For j = 5 To a.ListColumns.Count - 1
            b.ListRows.Add
            b.DataBodyRange.Cells(b.ListRows.Count, 1) = a.DataBodyRange.Cells(i, 1)
            b.DataBodyRange.Cells(b.ListRows.Count, 2) = a.DataBodyRange.Cells(i, 2)
            b.DataBodyRange.Cells(b.ListRows.Count, 3) = a.DataBodyRange.Cells(i, 3)
            b.DataBodyRange.Cells(b.ListRows.Count, 4) = a.DataBodyRange.Cells(i, 4)
            b.DataBodyRange.Cells(b.ListRows.Count, 5) = a.HeaderRowRange(j)
            b.DataBodyRange.Cells(b.ListRows.Count, 6) = a.DataBodyRange.Cells(i, j)
        Next
    Next
    Sheets("synthetiser").PivotTables(1).PivotCache.Refresh
End Sub

3- la génération du questionnaire et du système d'exploitation

Le fichier a été complété d'un onglet "maître" qui va

  • générer le questionnaire en s'appuyant sur le modèle
  • préparer le système de collecte des retours en mettant à jour l'onglet "collecter ..."
  • préparer l'analyse via le filtre avancé (onglet masque "filtre")
capture d ecran 626

Il est indispensable d'avoir le générateur et le modèle côte à côte dans le même dossier.

7questionnaire.xlsm (20.30 Ko)
Sub generer()
Dim derCol As String, i%, f1 As Worksheet, f2 As Worksheet, f3 As Worksheet, wb As Workbook, t As ListObject

    Set t = Sheets("generer questionnaire").ListObjects(1)

    Set f1 = Sheets("collecter les retours")
    derCol = Split(f1.Range("debut").End(xlToRight).Offset(0, 1).Address, "$")(1)
    f1.Range("F7:" & derCol & "8").ClearContents

    Set f3 = Sheets("filtre")
    f3.Rows("1:2").ClearContents

    raz "data1"
    raz "data2"
    raz "analyser"

    Set f2 = Sheets("analyser")
    For i = 1 To t.ListRows.Count

        f1.Cells(7, i + 5) = t.DataBodyRange.Cells(i, 1)
        f1.Cells(8, i + 5) = "H" & i + 3

        f2.ListObjects(1).ListRows.Add
        f2.ListObjects(1).DataBodyRange(f2.ListObjects(1).ListRows.Count, 1) = t.DataBodyRange.Cells(i, 1)

        f3.Cells(1, i) = t.DataBodyRange.Cells(i, 1)
        f3.Cells(2, i).FormulaR1C1 = _
                "=IF(OFFSET(Tanalyse[[#Headers],[Réponse]],COLUMN(),)="""",""<9"",OFFSET(Tanalyse[[#Headers],[Réponse]],COLUMN(),))"

    Next

    Set f1 = Sheets("data1")
    derCol = Split(f1.Range("B2").End(xlToRight).Offset(0, 1).Address, "$")(1)
    f1.Columns("F:" & derCol).Delete Shift:=xlToLeft

    MsgBox "système de collecte et d'analyse ok !"

    ' questionnaire
    Set wb = Workbooks.Open(ThisWorkbook.Path & "\" & "questionnaire.xlsm")
    With wb.Sheets(1).ListObjects(1)
        If Not .DataBodyRange Is Nothing Then .DataBodyRange.Delete
        For i = 1 To t.ListRows.Count
            .ListRows.Add
            .DataBodyRange(.ListRows.Count, 1) = t.DataBodyRange.Cells(i, 1)
        Next
    End With
    wb.Save
    wb.Close
    Set wb = Nothing

    MsgBox "questionnaire prêt à être envoyé !"

End Sub

Sub raz(donnees As String)
    If Not Sheets(donnees).ListObjects(1).DataBodyRange Is Nothing Then Sheets(donnees).ListObjects(1).DataBodyRange.Delete
End Sub
Rechercher des sujets similaires à "questionnaire echelle likert"