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
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.
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 SubL'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 SubLa 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 Sub3- 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")
Il est indispensable d'avoir le générateur et le modèle côte à côte dans le même dossier.
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