Option Explicit
Public Sub zone_imp()
Dim rng As Range, range1 As Range
Dim iniR As Integer, endR As Integer
Dim i As Integer, a As Integer, e As Integer, x As Integer
Dim ArrInput() As String
Dim ArrOutput As Variant
Dim xprint As String
Dim lastrow As Integer
Dim zone As String
Dim myCmPointsBase As Single
myCmPointsBase = Application.CentimetersToPoints(0.5)
i = 0
On Error Resume Next
ReDim ArrInput(0)
On Error GoTo 0
With ActiveSheet
lastrow = .Cells(.Rows.Count, "A").End(xlUp).Row
Set range1 = .Range("A10" & ":" & "A" & lastrow)
For Each rng In range1
If rng.Value = "Matricule :" Then
zone = ""
iniR = rng.Cells.Row
For a = iniR To lastrow
If .Range("A" & a).Value = "" Then
endR = .Range("A" & a).Cells.Row
Exit For
End If
Next a
If endR < iniR Then endR = lastrow
zone = "A" & iniR & ":M" & endR
ArrInput(i) = Range("B" & iniR) & "#" & zone
i = i + 1
ReDim Preserve ArrInput(i)
End If
Next rng
End With
If i > 0 Then
ArrInput = SortMyArray(ArrInput)
For x = LBound(ArrInput) To UBound(ArrInput)
ArrOutput = Split((ArrInput(x)), "#")
On Error Resume Next
xprint = ArrOutput(1)
On Error GoTo 0
If xprint <> "" Then
With ActiveSheet
With .PageSetup
.PrintArea = xprint ' print area
.PaperSize = xlPaperA4
.Orientation = xlPortrait
.Zoom = False
.FitToPagesTall = False
.FitToPagesWide = 1
.PrintGridlines = False
.PrintHeadings = False
' .PrintTitleRows = .Rows(1).Address
' .PrintQuality = -3 ' ATTENTION - dépend de chaque PC et imprimante
.FooterMargin = myCmPointsBase * 2
.HeaderMargin = myCmPointsBase * 2
.AlignMarginsHeaderFooter = True
.TopMargin = myCmPointsBase * 5
.RightMargin = myCmPointsBase * 3
.BottomMargin = myCmPointsBase * 5
.LeftMargin = myCmPointsBase * 3
.CenterHorizontally = True
.CenterVertically = False
' .CenterFooter = "&Iinsérer du texte ici"
' .RightFooter = "Pag. &P de &N"
'' .CenterHeader = "&G"
' .CenterHeader = "&D" & " - " & "&T" '
' With .CenterHeaderPicture
'' .FileName = "C:\...\mypic.jpg"
'' .ColorType = msoPictureAutomatic
'' .LockAspectRatio = msoTrue
'' .Height = myCmPointsBase * 2
' End With
' .OddAndEvenPagesHeaderFooter = True
' With .EvenPage
' .CenterFooter.Text = "&Binsérer du texte ici"
' .RightFooter.Text = "Pag &P de &N"
' With .CenterHeader
'' .Text = "&G"
' .Text = "insérer du texte ici"
' With .Picture
'' .FileName = "C:\...\mypic.jpg"
'' .ColorType = msoPictureAutomatic
'' .LockAspectRatio = msoTrue
'' .Height = myCmPointsBase * 2
' End With
' End With
' .RightHeader.Text = "insérer du texte ici"
End With
End With
'ActiveSheet.PrintOut
ActiveSheet.PrintPreview
End If
Next x
End If
If Not range1 Is Nothing Then Set range1 = Nothing
End Sub
Private Function SortMyArray(myArray As Variant) 'Dans l 'ordre croissant
Dim i As Long
Dim j As Long
Dim Temp
For i = LBound(myArray) To UBound(myArray) - 1
For j = i + 1 To UBound(myArray)
If UCase(myArray(i)) > UCase(myArray(j)) Then
Temp = myArray(j)
myArray(j) = myArray(i)
myArray(i) = Temp
End If
Next j
Next i
SortMyArray = myArray
End Function
