XL 2019 Impression dynamique vba

MTX

XLDnaute Nouveau
Bonjour
J'ai adapter un code trouver sur la toile des xls ,celui ci fonctionne plutôt bien sur un tableau,
N'ayan pas la maitrise de la VBA je vous demande votre aide .
De A à K j'ai 2 tableau cote a cote de nom diffèrent TAB1 (de A1 à F) et TAB2 (de G1 à K) dont les lignes sont variable pour chacun d'eux
Mon code ci dessous m'ajuste l'impression sur le TAB1 car il fais un count sur A1
Parfois Mon TAB2 en G est plus long que Mon TAB en A ,du coup je trouve pas le moyen de lui faire comparer les 2 colonne A et G et si l'une des 2
est plus grande l'ajustement se ferai sur la valeur la plus Grande.
ex1: si dans ma colonne A il y a 10 valeur et dans ma colonne G il y a 5 Valeurs ,alors ma mise en page serai de A1 à K10
ex2: si dans ma colonne A il y a 5 valeur et dans ma colonne G il y a 25 Valeurs ,alors ma mise en page serai de A1 à K25
J'espère avoir été claire.
Merci a vous
1654451548403.png


VB:
Sub AUTOAJUST()
Dim wS As Worksheet
 Set wS = ThisWorkbook.Sheets("r13b")
 
 WSLR = wS.Cells(Rows.Count, 1).End(xlUp).Row
 WSLC = wS.Cells(1, Columns.Count).End(xlToLeft).Column
 Set PrintArea = wS.Range("A1:K" & WSLR)
 
 wS.PageSetup.PrintArea = PrintArea.Address(0, 0)
End Sub
 
Solution
Bonjour
Il y a plusieurs solution suivant ce que vous voulez faire.
VB:
Sub AUTOAJUST2()
  Dim wS As Worksheet
  Dim dl As Integer, WSLR As Integer, WSLC As Integer
  Dim PrintArea As Range
  Dim i As Integer
 
' Pour boucler sur toutes les feuilles
  For Each wS In Worksheets
   WSLC = wS.Cells(1, Columns.Count).End(xlToLeft).Column
   For i = 1 To WSLC
     dl = wS.Cells(Rows.Count, i).End(xlUp).Row
     If dl > WSLR Then WSLR = dl
   Next i
  Set PrintArea = wS.Range("A1:K" & WSLR)
  wS.PageSetup.PrintArea = PrintArea.Address(0, 0)
 Next wS
 
End Sub

Sub AUTOAJUST3()
  Dim wS As Worksheet
  Dim dl As Integer, WSLR As Integer, WSLC As Integer
  Dim PrintArea As Range
  Dim i As Integer
 
' Pour boucler sur toutes les feuilles sauf...

yal

XLDnaute Occasionnel
Bonsoir
Voilà qui devrait fonctionner
VB:
Option Explicit

Sub AUTOAJUST()
Dim wS As Worksheet
Dim lo As ListObject
Dim dl As Integer, WSLR As Integer, WSLC As Integer
Dim PrintArea As Range


  Set wS = ThisWorkbook.Sheets("r13b")
  For Each lo In wS.ListObjects
    dl = lo.ListRows.Count + 1
    If dl > WSLR Then WSLR = dl
  Next lo
 
 WSLC = wS.Cells(1, Columns.Count).End(xlToLeft).Column
 Set PrintArea = wS.Range("A1:K" & WSLR)
 
 wS.PageSetup.PrintArea = PrintArea.Address(0, 0)
End Sub
 

yal

XLDnaute Occasionnel
Et pour le cas ou ça ne serait pas des vrais tableaux :
VB:
Sub AUTOAJUST()
Dim wS As Worksheet
Dim dl As Integer, WSLR As Integer, WSLC As Integer
Dim PrintArea As Range
Dim i As Integer

  Set wS = ThisWorkbook.Sheets("r13b")
  WSLC = wS.Cells(1, Columns.Count).End(xlToLeft).Column
  For i = 1 To WSLC
    dl = wS.Cells(Rows.Count, i).End(xlUp).Row
    If dl > WSLR Then WSLR = dl
  Next i
 
 Set PrintArea = wS.Range("A1:K" & WSLR)
 
 wS.PageSetup.PrintArea = PrintArea.Address(0, 0)
End Sub
 

MTX

XLDnaute Nouveau
Bonjour
Merci les propositions sont très bien je vous remercie ,Une dernière question svp J'ai 10 feuille identiquement pareille ,dois-je mettre ce code sur toute les feuille ou dans un module en ajoutant un déclaration spécifique .Dim wS As Workbook
Merci encore
 

yal

XLDnaute Occasionnel
Bonjour
Il y a plusieurs solution suivant ce que vous voulez faire.
VB:
Sub AUTOAJUST2()
  Dim wS As Worksheet
  Dim dl As Integer, WSLR As Integer, WSLC As Integer
  Dim PrintArea As Range
  Dim i As Integer
 
' Pour boucler sur toutes les feuilles
  For Each wS In Worksheets
   WSLC = wS.Cells(1, Columns.Count).End(xlToLeft).Column
   For i = 1 To WSLC
     dl = wS.Cells(Rows.Count, i).End(xlUp).Row
     If dl > WSLR Then WSLR = dl
   Next i
  Set PrintArea = wS.Range("A1:K" & WSLR)
  wS.PageSetup.PrintArea = PrintArea.Address(0, 0)
 Next wS
 
End Sub

Sub AUTOAJUST3()
  Dim wS As Worksheet
  Dim dl As Integer, WSLR As Integer, WSLC As Integer
  Dim PrintArea As Range
  Dim i As Integer
 
' Pour boucler sur toutes les feuilles sauf une
  For Each wS In Worksheets
    If wS.Name <> "Feuil2" Then ' Exclue la feuille : "Feuil2"
      WSLC = wS.Cells(1, Columns.Count).End(xlToLeft).Column
      For i = 1 To WSLC
        dl = wS.Cells(Rows.Count, i).End(xlUp).Row
        If dl > WSLR Then WSLR = dl
      Next i
      Set PrintArea = wS.Range("A1:K" & WSLR)
      wS.PageSetup.PrintArea = PrintArea.Address(0, 0)
    End If
 Next wS
 
End Sub

Sub AUTOAJUST4()
  Dim wS As Worksheet
  Dim dl As Integer, WSLR As Integer, WSLC As Integer
  Dim PrintArea As Range
  Dim i As Integer, j As Integer
  Dim arrayImpression()
 
' Pour boucler sur certaines feuilles
  arrayImpression = Array("Glossaire", "Glossaire 2") ' Liste des feuilles à traiter
  For j = 0 To UBound(arrayImpression)
    Set wS = Sheets(arrayImpression(j))
    WSLC = wS.Cells(1, Columns.Count).End(xlToLeft).Column
    For i = 1 To WSLC
      dl = wS.Cells(Rows.Count, i).End(xlUp).Row
      If dl > WSLR Then WSLR = dl
    Next i
    Set PrintArea = wS.Range("A1:K" & WSLR)
    wS.PageSetup.PrintArea = PrintArea.Address(0, 0)
 Next j
 
End Sub
 

Discussions similaires

Statistiques des forums

Discussions
311 709
Messages
2 081 754
Membres
101 812
dernier inscrit
trufu