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
