XL 2016 Besoin de compléter un code VBA

Linda42 · 23 Mai 2023

Bonjour,

J'ai un fichier qui me permet de cliquer sur une image (le logo CIBLEX) qui me copie une plage de données sur un nouveau classeur avec un certain nombre de paramètre a respecter. Je souhaiterais modifier le code VBA pour deux choses :
- renommer la feuille qui est copiée dans le nouveau classeur "Points"
- copier dans ce nouveau classeur, dans une feuille différente qui sera nommée "RATTRAPAGES - SPECIAUX" une autre plage qui se trouve en A106:N150, en copiant les éléments tel qu'ils sont sur le fichier source.

Il faut qu'en un clic, qu'un nouveau classeur soit créer avec deux feuilles pour chaque plage de données créées.

Merci pour votre aide

Linda

Oneida · 24 Mai 2023

Bonjour,

J'ai fait les modifs pour ajouter la feuille RATTRAPAGES - SPECIAUX et renommer la premiere feuille en Points

RATTRAPAGES - SPECIAUX
Je n'ai pas fait la partie impression ni les largeurs colonnes. A vous de voir

Linda42 · 24 Mai 2023

Oneida à dit:
Bonjour,

J'ai fait les modifs pour ajouter la feuille RATTRAPAGES - SPECIAUX et renommer la premiere feuille en Points

RATTRAPAGES - SPECIAUX
Je n'ai pas fait la partie impression ni les largeurs colonnes. A vous de voir

Merci beaucoup. Comment faire pour que la feuille point soit en premier. Par ailleurs, il faudrait que les tableau soit ajuster. Par exemple la colonne Date devrait être plus grande alors que la colonne A n'a pas besoin d'être aussi grande. J'ai bien compris qu'elle s'ajustait en fonction de la premier ligne mais du cout le tableau n'est pas très beau

Merci encore pour votre aide.

Oneida · 24 Mai 2023

Re,
Ok, vous ne connaissez pas la programmation VBA.

A quoi sert la vue avant impression?

cp4 · 24 Mai 2023

Bonsoir,

Je n'ai tout compris, mais j'ai consulté tes codes.
Tu utilises trop de Select, Selection.... qui ralentissent ton code.
au lieu de

VB:

Range("G8:M57").Select
    Selection.ClearContents

plutôt ceci

Code:

Range("G8:M57").ClearContents 'sans oublier la feuille sur laquelle doit agir le code'

Sheets("modèle").Range("G8:M57").ClearContents

ou
With Sheets("modèle")
.Range("G8:M57").ClearContents
'''''''
End With

edit: bonsoir @Oneida 😉

Oneida · 24 Mai 2023

Bonjour cp4,
en effet, y a pas mal a revoir dans son code mais l'objet du delit n'est pas la.

Linda42
Fichier modifie pour largeur colonnes et position feuilles

cp4 · 24 Mai 2023

Oneida à dit:
Bonjour cp4,
en effet, y a pas mal a revoir dans son code mais l'objet du delit n'est pas la.

Ok, on fait appel à Columbo😀.
Je passe aux aveux, je n'ai pas vraiment suivi la discussion, juste ouvert le fichier xlsm par curiosité.
J'ai aussi constaté qu'on avertit l'utilisateur à l'ouverture du fichier avant même que le projet n'ait abouti.

Oneida · 24 Mai 2023

cp4 à dit:
Ok, on fait appel à Columbo😀.
Je passe aux aveux, je n'ai pas vraiment suivi la discussion, juste ouvert le fichier xlsm par curiosité.
J'ai aussi constaté qu'on avertit l'utilisateur à l'ouverture du fichier avant même que le projet n'ait abouti.

Re,
Surprenant cet avertisement, mais il nous en faut beaucoup plus pour nous destabiliser

Linda42 · 24 Mai 2023

Oneida à dit:
Re,
Ok, vous ne connaissez pas la programmation VBA.

A quoi sert la vue avant impression?

Non, je ne connais pas, à part enregistrer des macro et essayer d'adapter en fonction de mes besoins.

J'avoue que la vue avant impression ne sert à rien ne connaissant pas VBA, je ne voudrais pas effacer du code par erreur. J'ai donc laisser le code avant impression.

Oneida à dit:
Bonjour cp4,
en effet, y a pas mal a revoir dans son code mais l'objet du delit n'est pas la.

Linda42
Fichier modifie pour largeur colonnes et position feuilles

Super ! Merci beaucoup

Mon code final est le suivant mais si vous pensez qu'on peut le réduire ou si il peut être améliorer, je suis à votre écoute. ;-)

VB:

 Option Explicit

Sub Export_Récap_Ciblex()
Dim wshSrc As Worksheet, wshDst As Worksheet, wshRS As Worksheet
Dim rngSrc As Range
'----------------------
Dim rngRS As Range          'RATTRAPAGES - SPECIAUX
'----------------------
Dim nomDst As Variant
Dim chemin As String

  Set wshSrc = Worksheets(ActiveSheet.Name)    ' nom de feuille à adapter
  Set rngSrc = wshSrc.Range("A1:BD52")         ' plage à copier à adapter
  Set rngRS = wshSrc.Range("X64:AP103")         ' plage à copier à adapter
  ' Création Export
  Set wshDst = Application.Workbooks.Add(xlWBATWorksheet).Worksheets(1)
  With wshDst
    .Name = "POINTS"
    rngSrc.Copy .Range("A1")                    ' cellule de destination à adapter
    .Cells.FormatConditions.Delete 'supprime les MFC copiées
    Dim c As Range
    For Each c In rngSrc
        .Range(c.Address).Interior.Color = c.DisplayFormat.Interior.Color 'copie la couleur affichée
        .Range(c.Address).Interior.Pattern = c.DisplayFormat.Interior.Pattern 'copie le motif affiché
    Next
    .Range("A1").Resize(rngSrc.Rows.Count, rngSrc.Columns.Count).Value = rngSrc.Value
    .Columns.AutoFit
    .Columns("A:A").ColumnWidth = 3.67
    .Columns("C:C").Delete

    With .Range("B4:I97")
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
    End With
    
    Columns("B:B").ColumnWidth = 30.89
    Columns("B:B").ColumnWidth = 43
    ActiveWindow.DisplayGridlines = False
    Range("E8").Select
    ActiveWindow.FreezePanes = True

    Rows("5:5").Select
    Selection.Delete Shift:=xlUp
    ActiveWindow.FreezePanes = False
    Range("E7").Select
    ActiveWindow.FreezePanes = True
    Columns("E:AZ").ColumnWidth = 5.78
    Columns("BB:BB").ColumnWidth = 12.11
    
    ActiveSheet.DrawingObjects.Delete
    '=================
    'GoTo suite
    '=================
    Application.PrintCommunication = False
    With .PageSetup
      .PaperSize = xlPaperA4: .Orientation = xlLandscape
      .RightFooter = "&P/&N"
      .CenterHorizontally = True: .Zoom = False
      .FitToPagesWide = 1: .FitToPagesTall = 1
      
          With ActiveSheet.PageSetup
        .PrintTitleRows = ""
        .PrintTitleColumns = ""
    End With
    Application.PrintCommunication = True
    ActiveSheet.PageSetup.PrintArea = ""
    Application.PrintCommunication = False
    With ActiveSheet.PageSetup
        .LeftHeader = ""
        .CenterHeader = ""
        .RightHeader = ""
        .LeftFooter = ""
        .CenterFooter = ""
        .RightFooter = ""
        .LeftMargin = Application.InchesToPoints(0)
        .RightMargin = Application.InchesToPoints(0)
        .TopMargin = Application.InchesToPoints(0)
        .BottomMargin = Application.InchesToPoints(0)
        .HeaderMargin = Application.InchesToPoints(0.31496062992126)
        .FooterMargin = Application.InchesToPoints(0.31496062992126)
        .PrintHeadings = False
        .PrintGridlines = False
        .PrintComments = xlPrintNoComments
        '.PrintQuality = 360
        .CenterHorizontally = True
        .CenterVertically = False
        .Orientation = xlLandscape
        .Draft = False
        .PaperSize = xlPaperA4
        .FirstPageNumber = xlAutomatic
        .Order = xlDownThenOver
        .BlackAndWhite = False
        .Zoom = False
        .FitToPagesWide = 1
        .FitToPagesTall = False
        .PrintErrors = xlPrintErrorsDisplayed
        .OddAndEvenPagesHeaderFooter = False
        .DifferentFirstPageHeaderFooter = False
        .ScaleWithDocHeaderFooter = True
        .AlignMarginsHeaderFooter = True
        .EvenPage.LeftHeader.Text = ""
        .EvenPage.CenterHeader.Text = ""
        .EvenPage.RightHeader.Text = ""
        .EvenPage.LeftFooter.Text = ""
        .EvenPage.CenterFooter.Text = ""
        .EvenPage.RightFooter.Text = ""
        .FirstPage.LeftHeader.Text = ""
        .FirstPage.CenterHeader.Text = ""
        .FirstPage.RightHeader.Text = ""
        .FirstPage.LeftFooter.Text = ""
        .FirstPage.CenterFooter.Text = ""
        .FirstPage.RightFooter.Text = ""
    End With
    Application.PrintCommunication = True
      
    End With
    Application.PrintCommunication = True
    .PrintPreview
  End With
 
suite:
    '==================================
    'Set wshRS = ActiveWorkbook.Worksheets.Add(, ActiveWorkbook.Worksheets(ActiveWorkbook.Worksheets.Count))
    Set wshRS = ActiveWorkbook.Worksheets.Add(, Worksheets("Points"))
    With wshRS
        .Name = "RATTRAPAGES - SPECIAUX"
        rngRS.Copy .Range("A1")                    ' cellule de destination à adapter
        .Cells.FormatConditions.Delete 'supprime les MFC copiées
        .Range("A1").Resize(rngRS.Rows.Count, rngRS.Columns.Count).Value = rngRS.Value
        .Columns.AutoFit
        .Columns("A:A").ColumnWidth = 1.71
        .Columns("B:B").ColumnWidth = 7
        .Columns("C:C").ColumnWidth = 7
        .Columns("D:D").ColumnWidth = 11
        .Columns("E:E").ColumnWidth = 11
        .Columns("F:F").ColumnWidth = 11
        .Columns("G:G").ColumnWidth = 9
        .Columns("H:H").ColumnWidth = 9
        .Columns("I:I").ColumnWidth = 9
        .Columns("J:J").ColumnWidth = 9
        .Columns("K:K").ColumnWidth = 9
        .Columns("L:L").ColumnWidth = 9
        .Columns("M:M").ColumnWidth = 7
        .Columns("N:N").ColumnWidth = 7
        .Columns("o:o").ColumnWidth = 7
        .Columns("p:p").ColumnWidth = 7
        .Columns("q:q").ColumnWidth = 7
        .Columns("r:r").ColumnWidth = 7
         Rows("6:6").Select
    Selection.RowHeight = 35
             Rows("7:38").Select
    Selection.RowHeight = 24
             Rows("39:39").Select
    Selection.RowHeight = 35
    Sheets("POINTS").Select
    End With
    '==================================
  ' Sauvegarde Export
  chemin = ThisWorkbook.Path & "\..\Tableau de bord\TDB - Mensuel\"
  nomDst = "Tableau de bord - " & wshSrc.Range("b4") & " - Colis Loire Express_98691225 - Ciblex France Mions"
  On Error Resume Next
  wshDst.Parent.SaveAs chemin & nomDst
  If Err > 0 Then
    If Dir(chemin, vbDirectory) = "" Then chemin = ThisWorkbook.Path & "\..\"
    nomDst = Application.GetSaveAsFilename(FileFilter:="Excel (*.xlsx),*.xlsx", InitialFileName:=chemin & nomDst)
    If nomDst <> False Then wshDst.Parent.SaveAs nomDst
  End If
  If wshDst.Parent.Saved Then wshDst.Parent.Close
  On Error GoTo 0
    Set wshSrc = Nothing
    Set wshRS = Nothing
    Set wshDst = Nothing
    Set rngSrc = Nothing
    Set rngRS = Nothing
End Sub

Staple1600 · 25 Mai 2023

Bonsoir le fil, @Linda42

Une suggestion en passant
Un allégement possible pour la partie dans ton code après : .Columns.AutoFit

VB:

Sub Version_courte()
With ActiveSheet
.Columns("A:A").ColumnWidth = 1.71
.Columns("D:F").ColumnWidth = 11
.Columns("G:L").ColumnWidth = 9
.Range("B:C,M:R").ColumnWidth = 7
End With
End Sub

Linda42 · 25 Mai 2023

Linda42 à dit:

Non, je ne connais pas, à part enregistrer des macro et essayer d'adapter en fonction de mes besoins.

J'avoue que la vue avant impression ne sert à rien ne connaissant pas VBA, je ne voudrais pas effacer du code par erreur. J'ai donc laisser le code avant impression.

Super ! Merci beaucoup

Mon code final est le suivant mais si vous pensez qu'on peut le réduire ou si il peut être améliorer, je suis à votre écoute. ;-)

VB:

 Option Explicit

Sub Export_Récap_Ciblex()
Dim wshSrc As Worksheet, wshDst As Worksheet, wshRS As Worksheet
Dim rngSrc As Range
'----------------------
Dim rngRS As Range          'RATTRAPAGES - SPECIAUX
'----------------------
Dim nomDst As Variant
Dim chemin As String

  Set wshSrc = Worksheets(ActiveSheet.Name)    ' nom de feuille à adapter
  Set rngSrc = wshSrc.Range("A1:BD52")         ' plage à copier à adapter
  Set rngRS = wshSrc.Range("X64:AP103")         ' plage à copier à adapter
  ' Création Export
  Set wshDst = Application.Workbooks.Add(xlWBATWorksheet).Worksheets(1)
  With wshDst
    .Name = "POINTS"
    rngSrc.Copy .Range("A1")                    ' cellule de destination à adapter
    .Cells.FormatConditions.Delete 'supprime les MFC copiées
    Dim c As Range
    For Each c In rngSrc
        .Range(c.Address).Interior.Color = c.DisplayFormat.Interior.Color 'copie la couleur affichée
        .Range(c.Address).Interior.Pattern = c.DisplayFormat.Interior.Pattern 'copie le motif affiché
    Next
    .Range("A1").Resize(rngSrc.Rows.Count, rngSrc.Columns.Count).Value = rngSrc.Value
    .Columns.AutoFit
    .Columns("A:A").ColumnWidth = 3.67
    .Columns("C:C").Delete

    With .Range("B4:I97")
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
    End With
   
    Columns("B:B").ColumnWidth = 30.89
    Columns("B:B").ColumnWidth = 43
    ActiveWindow.DisplayGridlines = False
    Range("E8").Select
    ActiveWindow.FreezePanes = True

    Rows("5:5").Select
    Selection.Delete Shift:=xlUp
    ActiveWindow.FreezePanes = False
    Range("E7").Select
    ActiveWindow.FreezePanes = True
    Columns("E:AZ").ColumnWidth = 5.78
    Columns("BB:BB").ColumnWidth = 12.11
   
    ActiveSheet.DrawingObjects.Delete
    '=================
    'GoTo suite
    '=================
    Application.PrintCommunication = False
    With .PageSetup
      .PaperSize = xlPaperA4: .Orientation = xlLandscape
      .RightFooter = "&P/&N"
      .CenterHorizontally = True: .Zoom = False
      .FitToPagesWide = 1: .FitToPagesTall = 1
     
          With ActiveSheet.PageSetup
        .PrintTitleRows = ""
        .PrintTitleColumns = ""
    End With
    Application.PrintCommunication = True
    ActiveSheet.PageSetup.PrintArea = ""
    Application.PrintCommunication = False
    With ActiveSheet.PageSetup
        .LeftHeader = ""
        .CenterHeader = ""
        .RightHeader = ""
        .LeftFooter = ""
        .CenterFooter = ""
        .RightFooter = ""
        .LeftMargin = Application.InchesToPoints(0)
        .RightMargin = Application.InchesToPoints(0)
        .TopMargin = Application.InchesToPoints(0)
        .BottomMargin = Application.InchesToPoints(0)
        .HeaderMargin = Application.InchesToPoints(0.31496062992126)
        .FooterMargin = Application.InchesToPoints(0.31496062992126)
        .PrintHeadings = False
        .PrintGridlines = False
        .PrintComments = xlPrintNoComments
        '.PrintQuality = 360
        .CenterHorizontally = True
        .CenterVertically = False
        .Orientation = xlLandscape
        .Draft = False
        .PaperSize = xlPaperA4
        .FirstPageNumber = xlAutomatic
        .Order = xlDownThenOver
        .BlackAndWhite = False
        .Zoom = False
        .FitToPagesWide = 1
        .FitToPagesTall = False
        .PrintErrors = xlPrintErrorsDisplayed
        .OddAndEvenPagesHeaderFooter = False
        .DifferentFirstPageHeaderFooter = False
        .ScaleWithDocHeaderFooter = True
        .AlignMarginsHeaderFooter = True
        .EvenPage.LeftHeader.Text = ""
        .EvenPage.CenterHeader.Text = ""
        .EvenPage.RightHeader.Text = ""
        .EvenPage.LeftFooter.Text = ""
        .EvenPage.CenterFooter.Text = ""
        .EvenPage.RightFooter.Text = ""
        .FirstPage.LeftHeader.Text = ""
        .FirstPage.CenterHeader.Text = ""
        .FirstPage.RightHeader.Text = ""
        .FirstPage.LeftFooter.Text = ""
        .FirstPage.CenterFooter.Text = ""
        .FirstPage.RightFooter.Text = ""
    End With
    Application.PrintCommunication = True
     
    End With
    Application.PrintCommunication = True
    .PrintPreview
  End With
 
suite:
    '==================================
    'Set wshRS = ActiveWorkbook.Worksheets.Add(, ActiveWorkbook.Worksheets(ActiveWorkbook.Worksheets.Count))
    Set wshRS = ActiveWorkbook.Worksheets.Add(, Worksheets("Points"))
    With wshRS
        .Name = "RATTRAPAGES - SPECIAUX"
        rngRS.Copy .Range("A1")                    ' cellule de destination à adapter
        .Cells.FormatConditions.Delete 'supprime les MFC copiées
        .Range("A1").Resize(rngRS.Rows.Count, rngRS.Columns.Count).Value = rngRS.Value
        .Columns.AutoFit
        .Columns("A:A").ColumnWidth = 1.71
        .Columns("B:B").ColumnWidth = 7
        .Columns("C:C").ColumnWidth = 7
        .Columns("D:D").ColumnWidth = 11
        .Columns("E:E").ColumnWidth = 11
        .Columns("F:F").ColumnWidth = 11
        .Columns("G:G").ColumnWidth = 9
        .Columns("H:H").ColumnWidth = 9
        .Columns("I:I").ColumnWidth = 9
        .Columns("J:J").ColumnWidth = 9
        .Columns("K:K").ColumnWidth = 9
        .Columns("L:L").ColumnWidth = 9
        .Columns("M:M").ColumnWidth = 7
        .Columns("N:N").ColumnWidth = 7
        .Columns("o:o").ColumnWidth = 7
        .Columns("p:p").ColumnWidth = 7
        .Columns("q:q").ColumnWidth = 7
        .Columns("r:r").ColumnWidth = 7
         Rows("6:6").Select
    Selection.RowHeight = 35
             Rows("7:38").Select
    Selection.RowHeight = 24
             Rows("39:39").Select
    Selection.RowHeight = 35
    Sheets("POINTS").Select
    End With
    '==================================
  ' Sauvegarde Export
  chemin = ThisWorkbook.Path & "\..\Tableau de bord\TDB - Mensuel\"
  nomDst = "Tableau de bord - " & wshSrc.Range("b4") & " - Colis Loire Express_98691225 - Ciblex France Mions"
  On Error Resume Next
  wshDst.Parent.SaveAs chemin & nomDst
  If Err > 0 Then
    If Dir(chemin, vbDirectory) = "" Then chemin = ThisWorkbook.Path & "\..\"
    nomDst = Application.GetSaveAsFilename(FileFilter:="Excel (*.xlsx),*.xlsx", InitialFileName:=chemin & nomDst)
    If nomDst <> False Then wshDst.Parent.SaveAs nomDst
  End If
  If wshDst.Parent.Saved Then wshDst.Parent.Close
  On Error GoTo 0
    Set wshSrc = Nothing
    Set wshRS = Nothing
    Set wshDst = Nothing
    Set rngSrc = Nothing
    Set rngRS = Nothing
End Sub

Staple1600 à dit:
Bonsoir le fil, @Linda42

Une suggestion en passant
Un allégement possible pour la partie dans ton code après : .Columns.AutoFit

VB:

Sub Version_courte() With ActiveSheet .Columns("A:A").ColumnWidth = 1.71 .Columns("D:F").ColumnWidth = 11 .Columns("G:L").ColumnWidth = 9 .Range("B:C,M:R").ColumnWidth = 7 End With End Sub

Merci 🙂 code modifié

Staple1600 · 25 Mai 2023

Re

Ici c'est bizarre, non ?

Enrichi (BBcode):

' on change la largeur de la colonne B
Columns("B:B").ColumnWidth = 30.89
'et on recommence
 Columns("B:B").ColumnWidth = 43
    ActiveWindow.DisplayGridlines = False
    Range("E8").Select ' Eviter les Select
    ActiveWindow.FreezePanes = True
Rows("5:5").Delete Shift:=xlUp
    ActiveWindow.FreezePanes = False
    Range("E7").Select ' Eviter les Select (bis) ;-)
    ActiveWindow.FreezePanes = True
    Columns("E:AZ").ColumnWidth = 5.78
    Columns("BB:BB").ColumnWidth = 12.11

Linda42 · 25 Mai 2023

Staple1600 à dit:

Re

Ici c'est bizarre, non ?

Enrichi (BBcode):

' on change la largeur de la colonne B
Columns("B:B").ColumnWidth = 30.89
'et on recommence
 Columns("B:B").ColumnWidth = 43
    ActiveWindow.DisplayGridlines = False
    Range("E8").Select ' Eviter les Select
    ActiveWindow.FreezePanes = True
Rows("5:5").Delete Shift:=xlUp
    ActiveWindow.FreezePanes = False
    Range("E7").Select ' Eviter les Select (bis) ;-)
    ActiveWindow.FreezePanes = True
    Columns("E:AZ").ColumnWidth = 5.78
    Columns("BB:BB").ColumnWidth = 12.11

Merci, j'ai modifié et mon code est le suivant (j'ai essayé de réduire un max les .select

VB:

  Option Explicit

Sub Export_Récap_Ciblex()
Dim wshSrc As Worksheet, wshDst As Worksheet, wshRS As Worksheet
Dim rngSrc As Range
'----------------------
Dim rngRS As Range          'RATTRAPAGES - SPECIAUX
'----------------------
Dim nomDst As Variant
Dim chemin As String

  Set wshSrc = Worksheets(ActiveSheet.Name) ' nom de feuille à adapter
  Set rngSrc = wshSrc.Range("A1:BD52")      ' plage à copier à adapter
  Set rngRS = wshSrc.Range("X64:AP103")     ' plage à copier à adapter
  ' Création Export
  Set wshDst = Application.Workbooks.Add(xlWBATWorksheet).Worksheets(1)
  With wshDst
    .Name = "POINTS"
    rngSrc.Copy .Range("A1")                    ' cellule de destination à adapter
    .Cells.FormatConditions.Delete 'supprime les MFC copiées
    Dim c As Range
    For Each c In rngSrc
        .Range(c.Address).Interior.Color = c.DisplayFormat.Interior.Color 'copie la couleur affichée
        .Range(c.Address).Interior.Pattern = c.DisplayFormat.Interior.Pattern 'copie le motif affiché
    Next
    .Range("A1").Resize(rngSrc.Rows.Count, rngSrc.Columns.Count).Value = rngSrc.Value
    .Columns.AutoFit
    .Columns("A:A").ColumnWidth = 3.67
    .Columns("C:C").Delete

    With .Range("B4:I97")
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
    End With
    
    Columns("B:B").ColumnWidth = 34
    Columns("c:c").ColumnWidth = 43
    Rows("5:5").Delete Shift:=xlUp
    Columns("E:AZ").ColumnWidth = 5.78
    Columns("BB:BB").ColumnWidth = 12.11
    ActiveSheet.DrawingObjects.Delete
    
    '=================
    'GoTo suite
    '=================
    Application.PrintCommunication = False
    With .PageSetup
      .PaperSize = xlPaperA4: .Orientation = xlLandscape
      .RightFooter = "&P/&N"
      .CenterHorizontally = True: .Zoom = False
      .FitToPagesWide = 1: .FitToPagesTall = 1
      
          With ActiveSheet.PageSetup
        .PrintTitleRows = ""
        .PrintTitleColumns = ""
    End With
    Application.PrintCommunication = True
    ActiveSheet.PageSetup.PrintArea = ""
    Application.PrintCommunication = False
    With ActiveSheet.PageSetup
        .LeftHeader = ""
        .CenterHeader = ""
        .RightHeader = ""
        .LeftFooter = ""
        .CenterFooter = ""
        .RightFooter = ""
        .LeftMargin = Application.InchesToPoints(0)
        .RightMargin = Application.InchesToPoints(0)
        .TopMargin = Application.InchesToPoints(0)
        .BottomMargin = Application.InchesToPoints(0)
        .HeaderMargin = Application.InchesToPoints(0.31496062992126)
        .FooterMargin = Application.InchesToPoints(0.31496062992126)
        .PrintHeadings = False
        .PrintGridlines = False
        .PrintComments = xlPrintNoComments
        '.PrintQuality = 360
        .CenterHorizontally = True
        .CenterVertically = False
        .Orientation = xlLandscape
        .Draft = False
        .PaperSize = xlPaperA4
        .FirstPageNumber = xlAutomatic
        .Order = xlDownThenOver
        .BlackAndWhite = False
        .Zoom = False
        .FitToPagesWide = 1
        .FitToPagesTall = False
        .PrintErrors = xlPrintErrorsDisplayed
        .OddAndEvenPagesHeaderFooter = False
        .DifferentFirstPageHeaderFooter = False
        .ScaleWithDocHeaderFooter = True
        .AlignMarginsHeaderFooter = True
        .EvenPage.LeftHeader.Text = ""
        .EvenPage.CenterHeader.Text = ""
        .EvenPage.RightHeader.Text = ""
        .EvenPage.LeftFooter.Text = ""
        .EvenPage.CenterFooter.Text = ""
        .EvenPage.RightFooter.Text = ""
        .FirstPage.LeftHeader.Text = ""
        .FirstPage.CenterHeader.Text = ""
        .FirstPage.RightHeader.Text = ""
        .FirstPage.LeftFooter.Text = ""
        .FirstPage.CenterFooter.Text = ""
        .FirstPage.RightFooter.Text = ""
    End With
    Application.PrintCommunication = True
      
    End With
    'Application.PrintCommunication = True
    '.PrintPreview
  End With
 
suite:
    '==================================
    'Set wshRS = ActiveWorkbook.Worksheets.Add(, ActiveWorkbook.Worksheets(ActiveWorkbook.Worksheets.Count))
    Set wshRS = ActiveWorkbook.Worksheets.Add(, Worksheets("Points"))
    With wshRS
        .Name = "RATTRAPAGES - SPECIAUX"
        rngRS.Copy .Range("A1")                    ' cellule de destination à adapter
        .Cells.FormatConditions.Delete 'supprime les MFC copiées
        .Range("A1").Resize(rngRS.Rows.Count, rngRS.Columns.Count).Value = rngRS.Value
        .Columns.AutoFit
        .Columns("A:A").ColumnWidth = 1.71
        .Columns("D:F").ColumnWidth = 11
        .Columns("G:L").ColumnWidth = 9
        .Range("B:C,M:R").ColumnWidth = 7
      Range("6:6,39:39").RowHeight = 35
      Rows("7:38").RowHeight = 24

    Sheets("POINTS").Select
    End With
    '==================================
  ' Sauvegarde Export
  chemin = ThisWorkbook.Path & "\..\Tableau de bord\TDB - Mensuel\"
  nomDst = "Tableau de bord - " & wshSrc.Range("b4") & " - Colis Loire Express_98691225 - Ciblex France Mions"
  On Error Resume Next
  wshDst.Parent.SaveAs chemin & nomDst
  If Err > 0 Then
    If Dir(chemin, vbDirectory) = "" Then chemin = ThisWorkbook.Path & "\..\"
    nomDst = Application.GetSaveAsFilename(FileFilter:="Excel (*.xlsx),*.xlsx", InitialFileName:=chemin & nomDst)
    If nomDst <> False Then wshDst.Parent.SaveAs nomDst
  End If
  If wshDst.Parent.Saved Then wshDst.Parent.Close
  On Error GoTo 0
    Set wshSrc = Nothing
    Set wshRS = Nothing
    Set wshDst = Nothing
    Set rngSrc = Nothing
    Set rngRS = Nothing
End Sub

Oneida · 26 Mai 2023

Bonjour,

Plus court et pas de rafraichissement d'ecran pendant execution

VB:

  Option Explicit

Sub Export_Récap_Ciblex()
Dim wshSrc As Worksheet, wshDst As Worksheet, wshRS As Worksheet
Dim rngSrc As Range
'----------------------
Dim rngRS As Range          'RATTRAPAGES - SPECIAUX
'----------------------
Dim nomDst As Variant
Dim chemin As String

  Set wshSrc = Worksheets(ActiveSheet.Name) ' nom de feuille à adapter
  Set rngSrc = wshSrc.Range("A1:BD52")      ' plage à copier à adapter
  Set rngRS = wshSrc.Range("X64:AP103")     ' plage à copier à adapter
 
  Application.ScreenUpdating = False
 
  ' Création Export
  Set wshDst = Application.Workbooks.Add(xlWBATWorksheet).Worksheets(1)
  With wshDst
    .Name = "POINTS"
    rngSrc.Copy .Range("A1")                    ' cellule de destination à adapter
    .Cells.FormatConditions.Delete 'supprime les MFC copiées
    Dim c As Range
    For Each c In rngSrc
        .Range(c.Address).Interior.Color = c.DisplayFormat.Interior.Color 'copie la couleur affichée
        .Range(c.Address).Interior.Pattern = c.DisplayFormat.Interior.Pattern 'copie le motif affiché
    Next
    .Range("A1").Resize(rngSrc.Rows.Count, rngSrc.Columns.Count).Value = rngSrc.Value
    .Columns.AutoFit
    .Columns("A:A").ColumnWidth = 3.67
    .Columns("C:C").Delete

    With .Range("B4:I97")
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
    End With
    Columns("B:B").ColumnWidth = 34
    Columns("C:C").ColumnWidth = 43
    Rows("5:5").Delete Shift:=xlUp
    Columns("E:AZ").ColumnWidth = 5.78
    Columns("BB:BB").ColumnWidth = 12.11
    ActiveSheet.DrawingObjects.Delete
    'Set wshRS = ActiveWorkbook.Worksheets.Add(, ActiveWorkbook.Worksheets(ActiveWorkbook.Worksheets.Count))
    Set wshRS = ActiveWorkbook.Worksheets.Add(, Worksheets("Points"))
    With wshRS
        .Name = "RATTRAPAGES - SPECIAUX"
        rngRS.Copy .Range("A1")                    ' cellule de destination à adapter
        .Cells.FormatConditions.Delete 'supprime les MFC copiées
        .Range("A1").Resize(rngRS.Rows.Count, rngRS.Columns.Count).Value = rngRS.Value
        .Columns.AutoFit
        .Columns("A:A").ColumnWidth = 1.71
        .Columns("D:F").ColumnWidth = 11
        .Columns("G:L").ColumnWidth = 9
        .Range("B:C,M:R").ColumnWidth = 7
      Range("6:6,39:39").RowHeight = 35
      Rows("7:38").RowHeight = 24
        Sheets("POINTS").Select
    End With
  ' Sauvegarde Export
  chemin = ThisWorkbook.Path & "\..\Tableau de bord\TDB - Mensuel\"
  nomDst = "Tableau de bord - " & wshSrc.Range("b4") & " - Colis Loire Express_98691225 - Ciblex France Mions"
  On Error Resume Next
  wshDst.Parent.SaveAs chemin & nomDst
  If Err > 0 Then
    If Dir(chemin, vbDirectory) = "" Then chemin = ThisWorkbook.Path & "\..\"
    nomDst = Application.GetSaveAsFilename(FileFilter:="Excel (*.xlsx),*.xlsx", InitialFileName:=chemin & nomDst)
    If nomDst <> False Then wshDst.Parent.SaveAs nomDst
  End If
  If wshDst.Parent.Saved Then wshDst.Parent.Close
  On Error GoTo 0
    Set wshSrc = Nothing
    Set wshRS = Nothing
    Set wshDst = Nothing
    Set rngSrc = Nothing
    Set rngRS = Nothing
    
    Application.ScreenUpdating = True
End Sub

Vous pouvez modifier les autres code ou il y a mise en pages pour impression

Effectuez une recherche sur Excel Downloads...

XL 2016 Besoin de compléter un code VBA

Linda42

XLDnaute Occasionnel

Pièces jointes

Oneida

Oneida

XLDnaute Impliqué

Pièces jointes

Linda42

XLDnaute Occasionnel

Oneida

XLDnaute Impliqué

cp4

XLDnaute Barbatruc

Oneida

XLDnaute Impliqué

Pièces jointes

cp4

XLDnaute Barbatruc

Oneida

XLDnaute Impliqué

Linda42

XLDnaute Occasionnel

Staple1600

XLDnaute Barbatruc

Linda42

XLDnaute Occasionnel

Staple1600

XLDnaute Barbatruc

Linda42

XLDnaute Occasionnel

Oneida

XLDnaute Impliqué

Discussions similaires

Nous accordons de l'importance à votre vie privée