Macro un fichier excel par onglet et rangement dans 1 dossier

Dim ws
Dim newWk As Workbook 
Dim Chemin As String
Chemin = "C:\Pijaku\Ne_fait_rien_de_ses_journées\CCM\"  
For Each ws In Worksheets
    Set newWk = Workbooks.Add(xlWBATWorksheet)
    ws.Copy newWk.Sheets(1)
    newWk.SaveAs (Chemin & ws.Name & ".xls")
    newWk.Close
    Set newWk = Nothing
Next ws 

Dim ws
Dim newWk As Workbook 
Dim objShell As Object, objFolder As Object
Dim Chemin As String

    Set objShell = CreateObject("Shell.Application")
    Set objFolder = objShell.BrowseForFolder(&H0&, "Choisir un répertoire", &H1&)

If objFolder Is Nothing Then
    MsgBox "Abandon opérateur", vbCritical, "Annulation"
Else
    Chemin = objFolder.ParentFolder.ParseName(objFolder.Title).Path & "\"
End If
If Chemin <> "" Then
    For Each ws In Worksheets
        Set newWk = Workbooks.Add(xlWBATWorksheet)
        ws.Copy newWk.Sheets(1)
        newWk.SaveAs (Chemin & ws.Name & ".xls")
        newWk.Close
        Set newWk = Nothing
    Next ws 
End If