Enregistrement de classeur

Bonjour,
Pour créer une copie de la feuille dans un nouveau classeur tu peux faire

EDIT : Code Faux supprimé.
Voir réponse dans le message : https://forums.commentcamarche.net/forum/affich-31588907-enregistrement-de-classeur#5

Cordialement,
Jordane

il memarque l'erreur suivante

la méthode'saveas'de l'objet'_workbook à échoué
ca c'est dès que je rajoute la ligne workbooks.add
il prend le nouveau classeur comme classeur actif donc il ne trouve plus la cellule demander

Voilou :

Sub essai()

Dim Derligne As Double
Dim Derligne1 As Double
Dim Wkbporte As Workbook
Dim Shporte As Worksheet

Dim clstest As String
clstest = "c:\tmp\Classeur2.xlsx"
 Workbooks.Open (clstest)
Set Wkbporte = ActiveWorkbook
Set Shporte = Wkbporte.ActiveSheet
'Set Wkbporte = Workbooks.Open("C:\VBAPointeuse\porte101214.xlsx")

 'Compare la colonne H ET D
Derligne = Shporte.Range("D1").End(xlDown).Row
Derligne1 = Shporte.Range("H1").End(xlDown).Row
For I = 1 To Derligne
    For j = 2 To Derligne1
         'si il trouve une corespondance alors il sauvegarde
        If Shporte.Range("H" & j).Value = Shporte.Range("D" & I).Value Then
            Application.DisplayAlerts = False
            'ajout d'un nouveau classeur
            Workbooks.Add
            'sauvegarde du nouveau classeur
            ActiveWorkbook.SaveAs _
            Filename:="c:\VBAPointeuse" & "\" & _
                       Shporte.Range("H" & j).Offset(0, -2).Value & _
                       Shporte.Range("H" & j).Offset(0, -1).Value & _
                       ".xlsx"
        End If
    Next j
Next I
End Sub

voila j'ai modifier le code et cela fonctionne

Sub nouveauclasseur()

Workbooks.Open ("C:\VBAPointeuse\porte101214.xlsx")

'Compare la colonne H ET D

Derligne = Range("D1").End(xlDown).Row
Derligne1 = Range("H1").End(xlDown).Row

For I = 1 To Derligne
For j = 2 To Derligne1
'si on trouve une corespondance alors on enregiste
If Range("H" & j).Value = Range("D" & I).Value Then

Application.DisplayAlerts = False

ActiveWorkbook.SaveAs Filename:="c:\VBAPointeuse" & "\" & Range("H" & j).Offset(0, -2).Value & Range("H" & j).Offset(0, -1).Value & (".xlsx")

'si le fichier existe on l'ouvre
' ElseIf Dir("c:\VBAPointeuse" & "\" & Range("H" & j).Offset(0, -2).Value & Range("H" & j).Offset(0, -1).Value & (".xlsx")) <> "" Then
' Workbooks.Open Filename:="c:\VBAPointeuse" & "\" & Range("H" & j).Offset(0, -2).Value & Range("H" & j).Offset(0, -1).Value & (".xlsx")
' Sheets.Add
' Sheets("porte101214").Delete

End If
Next j
Next I

End Sub