Sauter des lignes pour qu'un questionnaire ne soit pas coupé

**benjamin_malaussene** · 18/04/2014, 09h35

Bonjour,

Je dois générer un questionnaire aléatoire et sauter des lignes pour éviter que le questionnaire soit coupé au niveau d'une question au moment de l'impression. J'avais trouvé une méthode en comptant le nombre de lignes qui fonctionnait, mais elle n'est pas valide car si on modifie les hauteurs de lignes au niveau du titre du questionnaire, ça décale tout. Mais cette nouvelle méthode ne fonctionne pas, le programme saute des lignes quand il ne faut pas et les questions sont coupées. Est-ce que quelqu'un saurait d'où ça vient ?

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
Sub generer_questions()
 
Dim plage_questions As Range
Dim tirage As Integer, questions_possibles As Integer, nb_reponses As Integer, fin_du_questionnaire As Integer, bonnes_reponses As Integer
Dim question As String
Dim L As Integer, T As Integer, i As Integer, j As Integer
Dim hteur_totale As Single, nb_pages As Integer, taille_page As Single, hteur_page As Single, hteur_qui_reste As Single, nb_lignes As Integer
 
'Départ du timer
'StartTime = Timer
 
'Calcul de la taille d'une page
taille_page = 29.7 * (1 / 0.0352777778)
 
'On fixe la hauteur des lignes à 15
Rows("17:1100").RowHeight = 15
 
'On défusionne les cellules
Range("A17:H1100").Select
    With Selection
        .HorizontalAlignment = xlGeneral
        .VerticalAlignment = xlBottom
        .WrapText = True
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
 
'raz questionnaire precedent
Sheets("feuil2").Range("A17:H1100").ClearContents
Sheets("feuil2").CheckBoxes.Delete
 
'Nombre de questions du questionnaire
nb_questions = Sheets("feuil2").Range("O1").Value
 
'Nombre de questions possibles
questions_possibles = Sheets("feuil2").Range("O2").Value
 
'Messages d'erreur si le nombre de questions est trop important
If nb_questions > 99 Then
MsgBox "Le nombre de questions est supérieur au nombre total de questions disponibles"
Sheets("feuil2").Range("H1").ClearContents
Exit Sub
 
ElseIf questions_possibles > 99 Then
MsgBox "Le nombre de questions possibles est supérieur au nombre total de questions disponibles"
Sheets("feuil2").Range("H2").ClearContents
Exit Sub
 
ElseIf nb_questions > questions_possibles Then
MsgBox "Le nombre de questions doit être inférieur au nombre de questions possibles"
Sheets("feuil2").Range("H2").ClearContents
Exit Sub
 
End If
 
'Etablissement de la plage des questions
Set plage_questions = Sheets("feuil2").Range("A17:A1100")
 
'Au début le questionnaire commence 5 lignes après le titre
fin_du_questionnaire = Range("A" & Rows.Count).End(xlUp).Row + 5
 
'Position de départ des checkboxes
L = 25
T = Sheets("feuil2").Range(Cells(1, 1), Cells(fin_du_questionnaire, 1)).Height + 2 * 15
 
Randomize
 
'Boucle de génération des questions aléatoires
For i = 0 To nb_questions - 1
 
    'Tirage au sort d'un chiffre entre 1 et les questions possibles
    Do
        tirage = Int((questions_possibles * Rnd) + 1)
 
        'Sélection de la question correspondant au tirage
        question = WorksheetFunction.Index(Sheets("feuil1").Range("A2:A100"), tirage)
 
        'Vérification que la question n'existe pas déjà
    Loop Until Application.CountIf(plage_questions, question) = 0
 
    nb_reponses = Sheets("feuil1").Cells(tirage + 1, 2)
 
    'On regarde s'il reste assez de place sur la feuille pour la question suivante
    'Pour cela on calcule la position du questionnaire
    hteur_totale = Range(Cells(1, 1), Cells(fin_du_questionnaire, 1)).Height + Sheets("feuil2").PageSetup.TopMargin
 
    'Calcul du nombre de pages déjà occupées
    nb_pages = Int(hteur_totale / taille_page)
 
    'Calcul de la hauteur sur la page en cours
    hteur_page = hteur_totale - nb_pages * taille_page
 
    'Calcul de la hauteur qui reste
    hteur_qui_reste = taille_page - hteur_page - Sheets("feuil2").PageSetup.BottomMargin
 
    'Conversion en nombre de lignes
    nb_lignes = Round(hteur_qui_reste / 15, 0)
 
    If hteur_qui_reste < (3 + nb_reponses) * 15 Then
    fin_du_questionnaire = fin_du_questionnaire + nb_lignes
    T = T + nb_lignes * 15
    End If
 
    'Augmentation de la hauteur de la ligne des questions
    Range(Cells(fin_du_questionnaire, 1), Cells(fin_du_questionnaire, 8)).Select
    Selection.RowHeight = 45
 
    'Fusion des cellules et retour à la ligne automatique
    With Selection
        .HorizontalAlignment = xlGeneral
        .VerticalAlignment = xlBottom
        .WrapText = True
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = True
    End With
 
    'Affichage de la question
    Sheets("feuil2").Cells(fin_du_questionnaire, 1) = question
 
        'Génération des check boxes
        For j = 1 To nb_reponses
            Sheets("feuil2").CheckBoxes.Add(Left:=L, Top:=T, Width:=130, Height:=16).Select
            Selection.Characters.Text = Sheets("feuil1").Cells(tirage + 1, j + 3)
            Selection.Name = "Q" & tirage & "Rep" & j
            ActiveSheet.Shapes("Q" & tirage & "Rep" & j).ScaleWidth 4, msoFalse, msoScaleFromTopLeft
 
             T = T + 15
        Next
 
    'Pour la question suivante, il faut sauter un nombres de lignes correspondant au nombre de réponses
    fin_du_questionnaire = fin_du_questionnaire + nb_reponses + 2
    T = T + 4 * 15
 
Next
 
'Enregistrement du temps d'exécution
   'EndTime = Timer
 
'Ecriture du temps d'exécution dans la fenêtre debug
'Debug.Print "Execution time in seconds: ", EndTime - StartTime
 
'Affichage du temps d'exécution dans une message box
'MsgBox "Execution time in seconds: " + Format$(EndTime - StartTime)
 
End Sub