Sub Imprimer(choix As Boolean)
Dim r As Range, P As Range, n&, c As Range
Dim foundCell As Range
Set r = Range("B3:B" & Rows.Count)
' Si le tableau est vide, sortir de la macro
If Application.CountA(r) = 0 Then Exit Sub
' Si l'utilisateur a fait un choix de sélection
If choix Then
ActiveCell.Activate ' Au cas où la sélection est un objet
Set r = Intersect(Selection, r)
If r Is Nothing Then Exit Sub ' Si aucune intersection, sortir de la macro
Set r = IIf(r.Count = 1, r.Resize(2), r) ' S'assurer d'avoir au moins 2 cellules
End If
Application.ScreenUpdating = False ' Désactiver la mise à jour de l'écran pour accélérer
With Sheets("Imprimante")
.PageSetup.PrintArea = "" ' Effacer la zone d'impression
.PageSetup.FitToPagesWide = 1 ' 1 page en largeur
.PageSetup.FitToPagesTall = 1 ' 1 page en hauteur
' Parcourir chaque cellule constante dans la plage r
For Each r In r.SpecialCells(xlCellTypeConstants)
Set P = r.CurrentRegion ' Récupérer la région actuelle de la cellule
.Cells(6, 2) = r ' Copier la valeur de r dans la cellule (6, 2)
' Recherche de la cellule contenant "Observation*" dans la colonne 2
Set foundCell = .Columns(2).Find("Observation*", , xlValues)
' Si une cellule contenant "Observation*" est trouvée
If Not foundCell Is Nothing Then
.Range(.Rows(8), foundCell).Delete ' Effacer la zone de "Observation*" et en dessous
Else
' Aucun "Observation*" trouvé, continuer sans suppression
MsgBox "Aucune cellule contenant 'Observation*' trouvée dans la colonne 2", vbExclamation
End If
' Insérer des lignes en fonction de la taille de P
.Rows(8).Resize(5 * P.Rows.Count).Insert
' Boucler à travers les cellules de la colonne 2 dans P
n = 0
For Each c In P.Columns(2).Cells
.Cells(8 + n, 2).Resize(4) = Application.Transpose(c.Resize(, 4))
n = n + 5 ' Incrémentation de n pour décaler les lignes
Next c
' Imprimer ou afficher un aperçu selon la valeur de choix
If choix Then
.PrintPreview ' Afficher un aperçu avant impression
Else
.PrintOut ' Imprimer directement
End If
Next r
End With
Application.ScreenUpdating = True ' Réactiver la mise à jour de l'écran
End Sub
