Qu'est-ce qui vous en empêche ? Dans la macro il suffira de modifier l'adresse du tableau ou d'en prévoir 2 dès le départ.
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim T1 As Range, T2 As Range, c As Range
Set T1 = [Tableau1]: Set T2 = [Tableau2]
If Intersect(Target, Union(T1, T2)) Is Nothing Or Target.Count > 1 Then Exit Sub
If T1(1) = "" Then T1(1).Select: Exit Sub
Set c = T1.Find("", , xlValues)
If Not c Is Nothing Then c.Select: Exit Sub
If T2(1) = "" Then T2(1).Select: Exit Sub
Set c = T2.Find("", , xlValues)
If Not c Is Nothing Then c.Select
End Sub
Sub Macro1()
Dim Source As Range, i As Byte, T As Range, h As Long
Set Source = [masj].Resize(, 4)
Application.ScreenUpdating = False
Source.Columns(4).Insert xlToRight 'insertion à cause des cellules fusionnées en Feuil2
For i = 1 To 2 '2 tableaux nommés
Set T = Evaluate("Tableau" & i)
T = Source.Offset(h).Resize(T.Rows.Count).Value 'copie les valeurs
h = h + T.Rows.Count
Next
Source.Columns(4).Delete xlToLeft 'suppression de la colonne insérée
Sheets("Feuil2").PrintPreview 'pour tester
'Sheets("Feuil2").PrintOut 'imprime
MsgBox "Feuille imprimée"
End SubPourquoi ne l'avoir pas dit dès le début ?
Sub Macro1()
Dim Col1 As Range, Col2 As Range, i As Byte, T As Range, h As Long
Set Col1 = [masj] 'plage nommée
Set Col2 = [Psoir] 'plage nommée
Application.ScreenUpdating = False
With Feuil2 'CodeName de la feuille
For i = 1 To 2 '2 tableaux nommés
Set T = Evaluate("Tableau" & i)
T.Columns(1) = Col1.Offset(h).Resize(T.Rows.Count).Value 'copie les valeurs
T.Columns(4) = Col2.Offset(h).Resize(T.Rows.Count).Value 'copie les valeurs
h = h + T.Rows.Count
.PageSetup.PrintArea = T.EntireColumn.Address
.PrintPreview 'pour tester
'.PrintOut 'imprime
Next
End With
Feuil1.Activate 'facultatif
End SubA faire manuellement une fois pour toutes avec la commande Marges de l'onglet MISE EN PAGE.
