Créer nouveau fichier et y Coller une sélection

Bonjour à vous tous,

Un petit problème que je vous soumets:

J'ai un fichier dans lequel je fais une sélection, que je copie.

Je voudrais ensuite créer un nouveau fichier, dont je définis le nom à la demande (TEST01, par exemple), et y coller simplement ma sélection.

1) la coller en A1

2) la coller en B2, par exemple.

Tout fonctionne correctement (sélection, création) jusqu'à la commande de recopie dans le nouveau fichier correctement créé... !?

CA bug au moment de la recopie ...

Si vous avez une idée du comment et du pourquoi

Merci

CODE: (fichier annexé)

Sub CopyNew()

Chemin = ActiveWorkbook.Path

Dim NewClasseur As Workbook

' Sélection de la zone à recopier dans le nouveau fichier à créer:

DerLigne = Range("A65536").End(xlUp).Row

Range("A5" & ":AP" & DerLigne).Select

Selection.Copy

' Saisie du nom du nouveau fichier cible à créer:

Nom = InputBox("Entrer le nom du nouveau fichier: ", "Création du fichier cible")

' Création du nouveau fichier

Set NewClasseur = Application.Workbooks.Add

NewClasseur.SaveAs Filename:=Chemin & "\" & Nom

'Copie de la sélection dans le nouveau fichier

Cells.Select

ActiveSheet.Paste '------> c'est ici que ca BUG !!!

End Sub

Voici une méthode que j'ai testée et qui fonctionne:

Après avoir créé le nouveau fichier cible, il faut revenir au fichier source pour ressaisir la sélection à aller recopier !

Question corolaire:

Je constate que le fichier créé a l'extension .xlsx par défaut !

Peut-on spécifier une autre extension finale du fichier créé ?

CODE

Sub CopyNew()

Chemin = ActiveWorkbook.Path

Dim NewClasseur As Workbook

'Saisie du nom du nouveau fichier cible à créer:

Nom = InputBox("Entrer le nom du nouveau fichier: ", "Création du fichier cible")

'Création du nouveau fichier

Set NewClasseur = Application.Workbooks.Add

NewClasseur.SaveAs Filename:=Chemin & "\" & Nom

'Revenir au fichier source !

Windows("PasteNewFile2.xls").Activate

' Sélection de la zone à recopier ensuite dans le nouveau fichier à créer:

DerLigne = Range("A65536").End(xlUp).Row

Range("A5" & ":AP" & DerLigne).Select

Selection.Copy

'Retourner au fichier cible précédemment créé:

Windows(Nom & ".xlsx").Activate

'Copie de la sélection dans le nouveau fichier

Cells.Select

Range("B5").Select

ActiveSheet.Paste

Range("A1").Select

'Revenir fermer le fichier source

Windows("PasteNewFile2.xls").Activate

ActiveWorkbook.Close

End Sub

Bonjour,

Une alternative à ta méthode.

Cdlt.

Option Explicit

Public Sub DEMO()
Dim wb As Workbook, sFilename As String, lastRow As Long

    sFilename = InputBox("Entrer le nom du nouveau fichier: ", "Création du fichier cible")

    If sFilename = vbNullString Then Exit Sub

    Set wb = ThisWorkbook
    sFilename = wb.Path & Application.PathSeparator & sFilename

    Application.ScreenUpdating = False

    lastRow = Cells(Rows.Count, 1).End(xlUp).Row
    Range("A5:AP" & lastRow).Copy

    Workbooks.Add (xlWBATWorksheet)
    Worksheets(1).Range("B5").PasteSpecial Paste:=xlPasteAll
    Range("A1").Select
    Application.CutCopyMode = False

    ActiveWorkbook.SaveAs Filename:=sFilename, FileFormat:=xlOpenXMLWorkbook

    With wb
        .Activate
        .Close SaveChanges:=False
    End With

    Set wb = Nothing

End Sub

Bonjour Jean-Eric,

Merci pour ce code plus court et un rien plus rapide.

Je préfère ainsi ton alternative plus propre

@++