Réduire lignes de codes

gerson94 · 5 Juin 2009

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🙂

PMO2 · 8 Juin 2009

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

gerson94 · 9 Juin 2009

Re : Réduire lignes de codes

Bonjour tous, bonjour PMO2

J'avais pas vu ta réponse.Merci. Je l'applique et te fais signe.

Gerson

Réduire lignes de codes

gerson94

XLDnaute Occasionnel

PMO2

XLDnaute Accro

gerson94

XLDnaute Occasionnel

Discussions similaires

Réduire lignes de codes

gerson94

XLDnaute Occasionnel

PMO2

XLDnaute Accro

gerson94

XLDnaute Occasionnel

Discussions similaires

Privacy & Transparency

Privacy & Transparency