Private Sub CommandButton1_Click() 'Copier la source
Dim fichier$, Base1 As Range, nlig1&, Base2 As Range, nlig2&, Base3 As Range, nlig3, Signature As Range, nlig4&, deb As Range, nlig&, i&, x$, j&, h&
fichier = ThisWorkbook.Path & "\LIVRAISON.xlsx" 'chemin à adapter
If Dir(fichier) = "" Then MsgBox "Fichier SOURCE introuvable !", 48: Exit Sub
Set Base1 = Sheets("MODELE").[A1:M8]: nlig1 = Base1.Rows.Count
Set Base2 = Sheets("MODELE").[A9:M22]: nlig2 = Base2.Rows.Count
Set Base3 = Sheets("MODELE").[A23:M42]: nlig3 = Base3.Rows.Count
Set Signature = Sheets("MODELE").[A26:M42]: nlig4 = Signature.Rows.Count
Application.ScreenUpdating = False
UsedRange.Delete xlUp 'RAZ
PageSetup.PrintArea = Base1.EntireColumn.Address 'zone d'impression
PageSetup.Zoom = False
PageSetup.FitToPagesWide = 1 '1 page en largeur
Set deb = [A1]
With Workbooks.Open(fichier).Sheets(1).UsedRange
nlig = .Rows.Count
For i = 1 To nlig
x = LCase(.Cells(i, 1))
If x Like "*point de livraison*" Then
Base1.Copy deb
If deb.Row > 1 Then HPageBreaks.Add deb 'saut de page horizontal
deb(5, 4) = .Cells(i - 1, 2) 'date
deb(6, 4) = .Cells(i, 2) 'point de livraison
deb(2, 11) = .Cells(i, 2)
deb(6, 7) = .Cells(i, 4) 'ville
deb(7, 4) = .Cells(i + 1, 2)
Set deb = deb(nlig1 + 1)
ElseIf x Like "*menu*" Then
Base2.Copy deb
deb(1, 3) = .Cells(i, 2)
For j = i + 2 To nlig
x = LCase(.Cells(j, 1))
If x Like "*menu*" Or x Like "*cumul*" Or x Like "*livraison*" Then Exit For
Next j
h = j - i - 2
deb(3, 2).Resize(h) = .Cells(i + 2, 1).Resize(h).Value
deb(3, 6).Resize(h) = .Cells(i + 2, 2).Resize(h).Value
deb(3, 8).Resize(h, 3) = .Cells(i + 2, 3).Resize(h, 3).Value
Set deb = deb(nlig2 + 1)
i = j - 1
If x Like "*livraison*" Or j > nlig Then Signature.Copy deb(0): Set deb = deb(nlig4)
ElseIf x Like "*cumul*" Then
Base3.Copy deb
deb(2, 2) = .Cells(i + 1, 1)
deb(2, 6) = .Cells(i + 1, 2)
deb(2, 8).Resize(, 3) = .Cells(i + 1, 3).Resize(, 3).Value
If Not IsDate(.Cells(i + 2, 2)) Then
deb(3, 2) = .Cells(i + 2, 1)
deb(3, 6) = .Cells(i + 2, 2)
deb(3, 8).Resize(, 3) = .Cells(i + 2, 3).Resize(, 3).Value
End If
Set deb = deb(nlig3 + 1)
End If
Next i
.Parent.Parent.Close False
End With
'---suppression des lignes vides inutiles---
On Error Resume Next 'si aucune SpecialCell
Columns(1).SpecialCells(xlCellTypeFormulas, 16).EntireRow.Delete
Columns(1).ClearContents 'supprime les formule
With UsedRange: End With 'actualise la barre de défilement verticale
End Sub