Sauvegarder un onglet dans un nouveau classeur

Bonjour,

Tout est dans le titre,

J'ai commencé une macro, mais j'ai un bug au niveau de la variable chemin je pense.

Le nouveau classeur est bien créer (avec une feuil1 en trop mais je ne sais pas d'où ça vient)

Par contre aucune sauvegarde n'est réalisée, si quelqu'un à une idée ...

Sub ExportSAV()
Dim wk As Workbook
Dim ws As Worksheet

    Set wk = Workbooks.Add(xlWBATWorksheet)
    Set ws = ThisWorkbook.Worksheets("Rapport1")
    ws.Copy After:=wk.Sheets(Sheets.Count)

Dim nom, chemin As String
    nom = ThisWorkbook.Worksheets("Rapport1").Name & Month(Date) & Year(Date)
    'Test si dossier existe, sion on le créer via la fonction RépertoireExiste
    Call RépertoireExiste(ThisWorkbook.Worksheets("Feuil2").Range("B1"))
    Call RépertoireExiste(ThisWorkbook.Worksheets("Feuil2").Range("B1") & "\" & ThisWorkbook.Worksheets("Feuil2").Range("B2"))
    Call RépertoireExiste(ThisWorkbook.Worksheets("Feuil2").Range("B1") & "\" & ThisWorkbook.Worksheets("Feuil2").Range("B2") & "\" & ThisWorkbook.Worksheets("Feuil2").Range("B3"))
    chemin = ThisWorkbook.Worksheets("Feuil2").Range("B1") & "\" & ThisWorkbook.Worksheets("Feuil2").Range("B2") & "\" & ThisWorkbook.Worksheets("Feuil2").Range("B3") & "\" & nom
    ActiveWorkbook.ActiveSheet.SaveAs Filename:=chemin
    ActiveWorkbook.Close
End Sub
Function RépertoireExiste(chemin As String) As Boolean
On Error Resume Next
RépertoireExiste = GetAttr(chemin) And vbDirectory
    If RépertoireExiste = True Then
        Exit Function
    Else
        MkDir (chemin)
    End If
End Function

Bonjour

C'est là que le pas à pas est utile et des instructions de débogage

Utilises Debug.Print "ce que tu veux" et dans la fenêtre exécution tu auras le résultat

Fred35 a écrit :

(avec une feuil1 en trop mais je ne sais pas d'où ça vient)

La réponse est dans le code

Sub ExportSAV()
Dim wk As Workbook
Dim ws As Worksheet

'    Set wk = Workbooks.Add(xlWBATWorksheet)
'    Set ws = ThisWorkbook.Worksheets("Rapport1")
'    ws.Copy After:=wk.Sheets(Sheets.Count)

Dim nom, chemin As String
    nom = ThisWorkbook.Worksheets("Rapport1").Name & Month(Date) & Year(Date)

    ' Teste si les noms des dossiers sont conformes
    With ThisWorkbook.Worksheets("Feuil2")
      Debug.Print .Range("B1")
      Debug.Print .Range("B1") & "\" & .Range("B2")
      Debug.Print .Range("B1") & "\" & .Range("B2") & "\" & .Range("B3")
      Debug.Print .Range("B1") & "\" & .Range("B2") & "\" & .Range("B3") & "\" & nom
    End With
End

    Sheets("Rapport1").Copy

    'Test si dossier existe, sion on le créer via la fonction RépertoireExiste
    Call RépertoireExiste(ThisWorkbook.Worksheets("Feuil2").Range("B1"))
    Call RépertoireExiste(ThisWorkbook.Worksheets("Feuil2").Range("B1") & "\" & ThisWorkbook.Worksheets("Feuil2").Range("B2"))
    Call RépertoireExiste(ThisWorkbook.Worksheets("Feuil2").Range("B1") & "\" & ThisWorkbook.Worksheets("Feuil2").Range("B2") & "\" & ThisWorkbook.Worksheets("Feuil2").Range("B3"))
    chemin = ThisWorkbook.Worksheets("Feuil2").Range("B1") & "\" & ThisWorkbook.Worksheets("Feuil2").Range("B2") & "\" & ThisWorkbook.Worksheets("Feuil2").Range("B3") & "\" & nom
    'ActiveWorkbook.ActiveSheet.SaveAs Filename:=chemin
    ActiveWorkbook.SaveAs Filename:=chemin
    ActiveWorkbook.Close
End Sub

Je te propose un code (une fois que tu auras trouvé l'erreur)

Testé avec un autre répertoire racine

Sub ExportSAV()
Dim Nom, Chemin As String

  Nom = Sheets("Rapport1").Name & Month(Date) & Year(Date)
  With Sheets("Feuil2")
    On Error Resume Next
    MkDir (.Range("B1"))
    MkDir (.Range("B1") & "\" & .Range("B2"))
    MkDir (.Range("B1") & "\" & .Range("B2") & "\" & .Range("B3"))
    On Error GoTo 0
    Chemin = .Range("B1") & "\" & .Range("B2") & "\" & .Range("B3") & "\" & Nom
  End With

    Sheets("Rapport1").Copy
    ActiveWorkbook.SaveAs Filename:=Chemin
    ActiveWorkbook.Close
End Sub

Banzai64 a écrit :

C'est là que le pas à pas est utile et des instructions de débogage

Utilises Debug.Print "ce que tu veux" et dans la fenêtre exécution tu auras le résultat

Je ne maîtrise absolument pas le système de débogage

Comment fonctionne debug.print ?

En testant ton code, j'ai la même erreur

ActiveWorkbook.SaveAs Filename:=Chemin

J'ai l'impression qu'il cherche le chemin dans "Feuil2" du classeur créé et pas du classeur source.

Ca ne serait pas là mon erreur ?

Bonjour

Exécutes la 1ère macro en pas-à-pas

Cela remplace ce que l'on peut marquer dans des MsgBox

Fred35 a écrit :

En testant ton code, j'ai la même erreur

As-tu trouvé l'erreur ?

Pour info voici le résultat de la macro

C:\Test\Rapport\

C:\Test\Rapport\\2013

C:\Test\Rapport\\2013\Août

C:\Test\Rapport\\2013\Août\Rapport182013

j'ai corrigé dans Feuil2 en remplaçant C:\Test\Rapport\ par C:\Test\Rapport

En utilisant le mode pas à pas, j'ai supprimé le problème de Feuil1

    Sub ExportSAV()
    Dim wk As Workbook
    Dim ws As Worksheet

        'Set wk = Workbooks.Add(xlWBATWorksheet)
        Set ws = ThisWorkbook.Worksheets("Rapport1")
        ws.Copy

    Dim nom, chemin As String
        nom = ws.Name & Month(Date) & Year(Date)
        'Test si dossier existe, sion on le créer via la fonction RépertoireExiste
        Call RépertoireExiste(ThisWorkbook.Worksheets("Feuil2").Range("B1"))
        Call RépertoireExiste(ThisWorkbook.Worksheets("Feuil2").Range("B1") & "\" & ThisWorkbook.Worksheets("Feuil2").Range("B2"))
        Call RépertoireExiste(ThisWorkbook.Worksheets("Feuil2").Range("B1") & "\" & ThisWorkbook.Worksheets("Feuil2").Range("B2") & "\" & ThisWorkbook.Worksheets("Feuil2").Range("B3"))
        chemin = ThisWorkbook.Worksheets("Feuil2").Range("B1") & "\" & ThisWorkbook.Worksheets("Feuil2").Range("B2") & "\" & ThisWorkbook.Worksheets("Feuil2").Range("B3") & "\" & nom
        ActiveWorkbook.ActiveSheet.SaveAs Filename:=chemin
        ActiveWorkbook.Close
    End Sub
    Function RépertoireExiste(chemin As String) As Boolean
    On Error Resume Next
    RépertoireExiste = GetAttr(chemin) And vbDirectory
        If RépertoireExiste = True Then
            Exit Function
        Else
            MkDir (chemin)
        End If
    End Function

Mais c'est ici qu'il y a bug

ActiveWorkbook.ActiveSheet.SaveAs Filename:=chemin

et je pense que le bug est lié à cette ligne

chemin = ThisWorkbook.Worksheets("Feuil2").Range("B1") & "\" & ThisWorkbook.Worksheets("Feuil2").Range("B2") & "\" & ThisWorkbook.Worksheets("Feuil2").Range("B3") & "\" & nom

Bonjour

Dans la 1ère macro que j'ai posté ce problème est corrigé ( et même dans le 2ème)

    chemin = ThisWorkbook.Worksheets("Feuil2").Range("B1") & "\" & ThisWorkbook.Worksheets("Feuil2").Range("B2") & "\" & ThisWorkbook.Worksheets("Feuil2").Range("B3") & "\" & nom
    'ActiveWorkbook.ActiveSheet.SaveAs Filename:=chemin
   ActiveWorkbook.SaveAs Filename:=chemin
    ActiveWorkbook.Close
End Sub

Bonsoir,

en testant la correction ou la macro que tu proposes ça bloque toujours ici

    Sheets("Rapport1").Copy
    ActiveWorkbook.SaveAs Filename:=Chemin
    ActiveWorkbook.Close

Bonjour

Pas de souci

Voici le fichier pour les tests

et j'obtiens bien un fichier "Rapport182013.xls" dans le répertoire "....\2013\Août"

Je n'en sais pas plus

en lançant le fichier que tu viens de mettre ça bloque chez moi...

J'ai changé le disque dur depuis config, pareil...

J'ai créé le dossier et lancer la macro, toujours le même résultat...

Bonjour

C'est peut-être normal

Je t'ai remis ton chemin mais sans la correction

En B1 tu dois avoir seulement "C:\Test\Rapport"

Non, j'avais regardé et le chemin est correct c:\test\rapport.

Je ne comprend pas...

Bonjour

Pour tester j'ai mis le répertoire dans lequel il y a le fichier

Pour que cela fonctionne chez toi, il faut que le répertoire "C:\Test" existe

Comme cela en premier il crée le répertoire "Rapport"

Ensuite dans répertoire "Rapport" il crée le répertoire "2013"

Et enfin dans le répertoire "2013" il crée le dernier répertoire "Août" dans lequel il copie le fichier

Tes répertoires sont créés ?

Non aucun répertoire créer d'avance, je vais essayer en créant test

Effectivement en créant le répertoire test, ça fonctionne