Ceci est une page optimisée pour les mobiles. Cliquez sur ce texte pour afficher la vraie page.

XL 2016 Besoin de compléter un code VBA

L

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
Trier par date Trier par votes

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
Vote positif 0 Vote négatif
L

Linda42

XLDnaute Occasionnel
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
Cliquez pour agrandir...
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.
 
Vote positif 0 Vote négatif

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
 
Vote positif 0 Vote négatif

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:
Vote positif 0 Vote négatif
Solution

cp4

XLDnaute Barbatruc
Oneida à dit:
Bonjour cp4,
en effet, y a pas mal a revoir dans son code mais l'objet du delit n'est pas la.
Cliquez pour agrandir...
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.
 
Vote positif 0 Vote négatif

Oneida

XLDnaute Impliqué
Re,
Surprenant cet avertisement, mais il nous en faut beaucoup plus pour nous destabiliser
 
Réactions: cp4
Vote positif 0 Vote négatif
L

Linda42

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

A quoi sert la vue avant impression?
Cliquez pour agrandir...
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
Cliquez pour agrandir...
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
 
Vote positif 0 Vote négatif

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
 
Vote positif 0 Vote négatif
L

Linda42

XLDnaute Occasionnel
Merci code modifié
 
Vote positif 0 Vote négatif

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
 
Vote positif 0 Vote négatif
L

Linda42

XLDnaute Occasionnel
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
 
Vote positif 0 Vote négatif

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
 
Vote positif 0 Vote négatif
Identifiez-vous ou inscrivez-vous pour participer.

Discussions similaires

D
  • Question
Microsoft 365 Comment exporter certaines feuilles d'un classeur dans un nouveau classeur.
Réponses
2
Affichages
244
Jacky67
J
  • Question
Microsoft 365 Code VBA
Réponses
10
Affichages
748
jebibo
J
B
  • Question
XL 2016 VBA - Ajout de consignes dans le corps d'un mail
Réponses
3
Affichages
200
kiki29
F
  • Question
XL 2021 Liste déroulante vers un autre classeur
Réponses
1
Affichages
325
Dudu2
V
  • Question
Microsoft 365 VBA deux document Excel
Réponses
10
Affichages
457
vroumvroum
V
T
  • Résolu(e)
XL 2016 Modification de données en fonction d'une valeur
Réponses
3
Affichages
388
therse
T
P
  • Résolu(e)
XL 2021 Besoin d'aide pour copier/coller données de plusieurs classeurs
2
Réponses
20
Affichages
681
Pac41240
P
C
  • Résolu(e)
Autres Code VBA pour recherche et copie/coller de ligne avec mot clé.
Réponses
12
Affichages
523
Corentin26270
C
  • Résolu(e)
Microsoft 365 Programme de lecture d'un très gros livre (3 différents livres par semaine et un chapitre de chaque par jour)
2
Réponses
18
Affichages
628
crocrocro
C
F
  • Résolu(e)
Microsoft 365 Code vba pour Ouvrir un fichier et copier son contenu dans un classeur existant à partir de la boite de dialogue
Réponses
3
Affichages
865
Faroyo
F
Menu
Connexion
S'inscrire
Les cookies sont requis pour utiliser ce site. Vous devez les accepter pour continuer à utiliser le site. En savoir plus…