Réduire lignes de codes

  • Initiateur de la discussion Initiateur de la discussion gerson94
  • Date de début Date de début

Boostez vos compétences Excel avec notre communauté !

Rejoignez Excel Downloads, le rendez-vous des passionnés où l'entraide fait la force. Apprenez, échangez, progressez – et tout ça gratuitement ! 👉 Inscrivez-vous maintenant !

gerson94

XLDnaute Occasionnel
Bonjour toutes et tous,

Grâce à vous j'ai pu mettre en place ce code qui me permet de créer un nouveau classeur et faire du copier coller des onglets.
Il fonctionne bien, mais je souhaite le raccoucir, l'optimiser surtout au niveau du copier/coller....


Code:
Sub Macro()


Dim WB As Workbook
Dim Nom_Ext As String

'On crée un nouveau classeur
Set WB = Application.Workbooks.Add
Nom = InputBox("Veuillez saisir le nom du fichier", "Nom du fichier à créer :")
If Nom = "" Then MsgBox "Abandon": Exit Sub
Nom_Ext = Nom & ".xls"
ActiveWindow.Caption = Nom_Ext

'dans l'outil on sélectionne la feuille "Aff"
ThisWorkbook.Activate
Sheets("Aff").Select
Range("A1:S1650").Select
Selection.Copy

'dans le nouveau classeur crée on colle les informations en valeur et format
WB.Windows(1).Activate
Sheets("Feuil1").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, SkipBlanks:=False, Transpose:=False

'dans l'outil on sélectionne la feuille "Dis"
ThisWorkbook.Activate
Sheets("Dis").Select
Range("B7:M110").Select
Selection.Copy

'dans le nouveau classeur crée on colle les informations en valeur et format
WB.Windows(1).Activate
Sheets("Feuil2").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, SkipBlanks:=False, Transpose:=False

'dans l'outil on sélectionne la feuille "Pré"
ThisWorkbook.Activate
Sheets("Pré").Select
Range("A4:J30").Select
Selection.Copy

'dans le nouveau classeur crée on colle les informations en valeur et format
WB.Windows(1).Activate
Sheets("Feuil3").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, SkipBlanks:=False, Transpose:=False

End Sub

Merci d'avance et bon appétit.

Gerson🙂
 
Re : Réduire lignes de codes

Bonjour,

Peut-être un truc du genre

Code:
Sub Macro()
Dim WBsource As Workbook
Dim WB As Workbook
Dim Nom_Ext As String
Set WBsource = ThisWorkbook
'On crée un nouveau classeur
Set WB = Application.Workbooks.Add
Nom = InputBox("Veuillez saisir le nom du fichier", "Nom du fichier à créer :")
If Nom = "" Then MsgBox "Abandon": Exit Sub
Nom_Ext = Nom & ".xls"
ActiveWindow.Caption = Nom_Ext
'dans l'outil on sélectionne la feuille "Aff"
WBsource.Sheets("Aff").Range("A1:S1650").Copy
'dans le nouveau classeur crée on colle les informations en valeur et format
WB.Activate
PasteSpc ("Feuil1")
'dans l'outil on sélectionne la feuille "Dis"
WBsource.Sheets("Dis").Range("B7:M110").Copy
'dans le nouveau classeur crée on colle les informations en valeur et format
WB.Activate
PasteSpc ("Feuil2")
'dans l'outil on sélectionne la feuille "Pré"
WBsource.Sheets("Pré").Range("A4:J30").Copy
'dans le nouveau classeur crée on colle les informations en valeur et format
WB.Activate
PasteSpc ("Feuil3")
End Sub

Sub PasteSpc(S As Worksheet)
S.Select
With Selection
  .PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
  .PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
End With
End Sub

Cordialement.

PMO
Patrick Morange
 
- Navigue sans publicité
- Accède à Cléa, notre assistante IA experte Excel... et pas que...
- Profite de fonctionnalités exclusives
Ton soutien permet à Excel Downloads de rester 100% gratuit et de continuer à rassembler les passionnés d'Excel.
Je deviens Supporter XLD

Discussions similaires

Réponses
10
Affichages
632
Réponses
18
Affichages
402
Réponses
2
Affichages
332
Réponses
17
Affichages
1 K
  • Question Question
Microsoft 365 Erreur de format
Réponses
5
Affichages
517
Retour