Macro pour imprimer d'après une liste de noms

Option Explicit


Sub PrintLooping()
Dim Cell As Range
Dim WSSource As Worksheet
Dim WSCible As Worksheet

Set WSSource = Worksheets('LISTE')
Set WSCible = Worksheets('PROJET')


    For Each Cell In WSSource.Range('A2:A21')
        With WSCible
            .Range('A1') = Cell
            .PrintOut
        End With
    Next

End Sub

Cliquez pour agrandir...

Option Explicit


Sub PrintLooping()
Dim Cell As Range
Dim WSSource As Worksheet
Dim WSCible As Worksheet

Set WSSource = Worksheets('LISTE')
Set WSCible = Worksheets('PROJET')


    For Each Cell In WSSource.Range('A2:A21')
        With WSCible
            .Range('A1') = Cell
            .Calculate
            .PageSetup.PrintArea = 'A150:K200' 'A adapter à ta plage contenant
                                                ' les pages 2 à 7...
                                               
            .PrintPreview 'Pour tester sans gaspillage de papier
            '.PrintOut 'Remettre actif ensuite
        End With
    Next

End Sub

Cliquez pour agrandir...

Option Explicit


Sub PrintLooping()
Dim Cell As Range
Dim WSSource As Worksheet
Dim WSCible As Worksheet
Dim PageFrom As Byte, PageTo As Byte, NbCopy As Byte


Set WSSource = Worksheets('IMPRIM')

Set WSCible = Worksheets(CStr(WSSource.Range('C6').Text))

With WSSource
    PageFrom = .Range('C9')
    PageTo = .Range('D9')
    NbCopy = .Range('D6')
End With


    For Each Cell In WSSource.Range('A6:A25')
    If Not Cell = '' Then
        With WSCible
            .Range('A1') = Cell
            .Calculate
            .PrintOut From:=PageFrom, To:=PageTo, Copies:=NbCopy
        End With
    End If
    Next

End Sub

Cliquez pour agrandir...

Sub PrintLoopingSpecial()
Dim WSSource As Worksheet
Dim WSCible As Worksheet
Dim RangeListName As Range, CellName As Range
Dim RangeParaIni As Range, CellPara As Range
Dim PageFrom As Byte, PageTo As Byte, NbCopy As Byte


Set WSSource = Worksheets('IMPRIM')


With WSSource
    Set RangeParaIni = .Range('G6:G16')
    Set RangeListName = .Range('A6:A25')
End With

For Each CellPara In RangeParaIni
    If Not CellPara = '' Then
       
        Set WSCible = Worksheets(CStr(CellPara))
            NbCopy = CellPara.Offset(0, 1)
            PageFrom = CellPara.Offset(0, 2)
            PageTo = CellPara.Offset(0, 3)
                    For Each CellName In RangeListName
                            If Not CellName = '' Then
                                With WSCible
                                    .Range('A1') = CellName
                                    .Calculate
                                    .PrintOut From:=PageFrom, To:=PageTo, Copies:=NbCopy
                                End With
                            End If
                    Next
      End If
Next
End Sub

Cliquez pour agrandir...