XL 2016 Besoin de compléter un code VBA

Linda42

XLDnaute Occasionnel
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
 

Pièces jointes

  • Tableau de bord 2023essai.xlsm
    215.7 KB · Affichages: 2

Oneida

XLDnaute Impliqué
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
 

Pièces jointes

  • Linda42_Tableau de bord 2023essai.xlsm
    263.1 KB · Affichages: 2
  • test_Linda.xlsx
    31.4 KB · Affichages: 1

Linda42

XLDnaute Occasionnel
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.
 

cp4

XLDnaute Barbatruc
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

XLDnaute Impliqué
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
 

Pièces jointes

  • Linda42_Tableau de bord 2023essai.xlsm
    265.6 KB · Affichages: 5
  • test_Linda.xlsx
    36.6 KB · Affichages: 1
Dernière édition:

Linda42

XLDnaute Occasionnel
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.

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

XLDnaute Barbatruc
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

XLDnaute Occasionnel
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
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

XLDnaute Barbatruc
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

XLDnaute Occasionnel
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

XLDnaute Impliqué
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
 

Discussions similaires

Réponses
2
Affichages
98
  • Résolu(e)
Microsoft 365 Programme VBA
Réponses
3
Affichages
402

Statistiques des forums

Discussions
311 710
Messages
2 081 781
Membres
101 817
dernier inscrit
carvajal