Copier/coller feuille via macro et la renommer avant enregistrement

[gerson94]

Bonjour toutes et tous,
Je me mets de plus en plus aux macros en glanant çà et là des bouts de code. Ma macro copie des données d'une feuille vers une feuille vierge. Mon problème, c'est qu'une fois que j'ai donné un titre à mon nouveau classeur via le "Inputbox" ce n'est pas pris en compte au moment de l'enregistrement.
Et mon deuxième problème est que je souhaite nommer automatiquement mon nouvel onglet du même nom que la feuille créée. Merci pour votre aide.

Sub Extraction() ' 

Dim WB As Workbook
Dim Nom_Ext As String

Set WB = Application.Workbooks.Add
Nom = InputBox("Veuillez saisir votre titre", "Titre :")
If Nom = "" Then MsgBox "Abandon": Exit Sub
Nom_Ext = Nom & ".xls"
ActiveWindow.Caption = Nom_Ext

Windows("ClasseurTest.xls").Activate
Range("A2:I55").Select
Selection.Copy

WB.Windows(1).Activate
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, SkipBlanks:=False, Transpose:=False

'on met en forme
    Range("G5:I8").Select
    Selection.Interior.ColorIndex = 15
    Range("C11:F11").Select
    Selection.Interior.ColorIndex = 15
    Range("A15:D15").Select
    Selection.Interior.ColorIndex = 15
    Range("G15:H15").Select
    Selection.Interior.ColorIndex = 15
    Range("A16:I43").Select
    Selection.FormatConditions.Delete
    Selection.FormatConditions.Add Type:=xlCellValue, Operator:=xlEqual, _
        Formula1:="0"
    Selection.FormatConditions(1).Font.ColorIndex = 2

    Range("A1:I54").Select
    Range("A54").Activate
    Selection.Borders(xlDiagonalDown).LineStyle = xlNone
    Selection.Borders(xlDiagonalUp).LineStyle = xlNone
    With Selection.Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With

    Rows("1:1").Select
    Selection.RowHeight = 45
    ActiveWindow.DisplayGridlines = False
     
    Range("A6").Select

End Sub

Gerson

 

[PMO2]

Re : Copier/coller feuille via macro et la renommer avant enregistrement

Bonjour,

Essayez avec votre code modifié

'### Constante à adapter ###
Const CHEMIN As String = "C:\"
'################

Sub Extraction()
Dim WB As Workbook
Dim Nom_Ext As String
Dim Nom
Dim i&
Nom = InputBox("Veuillez saisir votre titre", "Titre :")
If Nom = "" Then MsgBox "Abandon": Exit Sub
Set WB = Application.Workbooks.Add
Nom_Ext = Nom & ".xls"
ActiveWindow.Caption = Nom_Ext
Windows("ClasseurTest.xls").Activate
Range("A2:I55").Copy
WB.Windows(1).Activate
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
'on met en forme
Range("G5:I8,C11:F11,A15:D15,G15:H15").Interior.ColorIndex = 15
With Range("A16:I43")
  .FormatConditions.Delete
  .FormatConditions.Add Type:=xlCellValue, Operator:=xlEqual, Formula1:="0"
  .FormatConditions(1).Font.ColorIndex = 2
End With
With Range("A1:I54")
  For i& = xlDiagonalDown To xlDiagonalUp
    .Borders(i&).LineStyle = xlNone
  Next i&
  For i& = xlEdgeLeft To xlEdgeRight
    With .Borders(i&)
      .LineStyle = xlContinuous
      .Weight = xlThin
      .ColorIndex = xlAutomatic
    End With
  Next i&
End With
Rows("1:1").RowHeight = 45
ActiveWindow.DisplayGridlines = False
Range("A6").Select
WB.SaveAs CHEMIN & Nom_Ext
End Sub

Cordialement.

PMO
Patrick Morange