Sauvegarder 1 feuil dans un Dossier Zip

[MuscatMimi]

Bonjour a tous

Dans le code ci-dessous qui est de ron de Bruin

ça sauvegarde le classeur entier

je ne suis pas arrivé a le modifier, pour ne Sauvegarder qu'une seul feuille


Si quelqu'un a une idée a ce sujet


Sub NewZip(sPath)
'Create empty Zip File
'Changed by keepITcool Dec-12-2005
If Len(Dir(sPath)) > 0 Then Kill sPath
Open sPath For Output As #1
Print #1, Chr$(80) & Chr$(75) & Chr$(5) & Chr$(6) & String(18, 0)
Close #1
End Sub

Sub Zip_ActiveWorkbook()
Dim strDate As String, DefPath As String, Str As String
Dim FileNameZip, FileNameXls
Dim oApp As Object
Dim FileExtStr As String
' Dim Temp As String 'Crée le Dossier Zip dans le Dossier Temp
Dim Nom As String 'Créé Le Dossier Zip dans le Dossier du Classeur

'DefPath = "F:\Mes Documents Cat\Nouveau dossier\AA\" '<< Change

'10--Crée le Dossier Zip dans Dossier Temp
' DefPath = ThisWorkbook.path & "\Temp" '<<Copy dans Dossier "AA"

'11--Crée le Dossier Zip dans Dossier du Fichier
DefPath = ThisWorkbook.path & "\" '<<Copy dans Dossier "AA"


If Right(DefPath, 1) <> "\" Then

DefPath = DefPath
End If

'--Create date/time string and the temporary xl* and Zip file name
If Val(Application.Version) < 12 Then
FileExtStr = ".xls"
Else
Select Case ActiveWorkbook.FileFormat
Case 51: FileExtStr = ".xlsx"
Case 52: FileExtStr = ".xlsm"
Case 56: FileExtStr = ".xls"
Case 50: FileExtStr = ".xlsb"
Case Else: FileExtStr = "notknown"
End Select
If FileExtStr = "notknown" Then
MsgBox "Sorry unknown file format"
Exit Sub
End If
End If

strDate = Format(Now, " yyyy-mm-dd h-mm-ss")

'*******--Créé le Fichier Zip dans le Dossier du Fichier*****
'avec Nom du Fichier et date du Jour

'FileNameZip = DefPath & Left(ActiveWorkbook.Name, _
'Len(ActiveWorkbook.Name) - Len(FileExtStr)) & strDate & ".zip"
'************************************************************

'******11'--Créé le Fichier Zip dans le Dossier du Fichier********
FileNameZip = DefPath & "Nom" & ".zip"
'*********************************************************


'******10'--Créé le Fichier Zip dans le Dossier Temp********
' FileNameZip = DefPath & Temp & ".zip"
'*********************************************************

FileNameXls = DefPath & Left(ActiveWorkbook.Name, _
Len(ActiveWorkbook.Name) - Len(FileExtStr)) & strDate & FileExtStr

If Dir(FileNameZip) = "" And Dir(FileNameXls) = "" Then

'Make copy of the activeworkbook
ActiveWorkbook.SaveCopyAs FileNameXls

'Create empty Zip File
NewZip (FileNameZip)

'Copy the file in the compressed folder
Set oApp = CreateObject("Shell.Application")
oApp.Namespace(FileNameZip).CopyHere FileNameXls

'Keep script waiting until Compressing is done
On Error Resume Next
Do Until oApp.Namespace(FileNameZip).items.Count = 1
Application.Wait (Now + TimeValue("0:00:01"))
Loop
On Error GoTo 0
'Delete the temporary xls file
Kill FileNameXls

MsgBox "Your Backup is saved here: " & FileNameZip

Else
MsgBox "FileNameZip or/and FileNameXls exist"

End If
End Sub
[/CODE]

Cordialement

 

[Guest]

Re : Sauvegarder 1 feuil dans un Dossier Zip

Bonjour,

Copy ta feuille dans un nouveau classeur par:

Sheets("MaFeuille").Copy
ActiveWorkBook.SaveAs "CheminEtNomDuFichier"

Ensuite tu zip ce nouveau fichier
Et éventuellement, tu le supprimes

Kill "CheminEtNomDuFichier"

A+

 

[MuscatMimi]

Re : Sauvegarder 1 feuil dans un Dossier Zip

Bonsoir Hasco

Merci de ta réponse
Mais en fait ça je sais faire

Ce que je désire arriver a faire (enfin si c'est possible) d'utiliser
le Code de Ron en Sauvegardant une Feuille de mon Classeur actif,et non le classeur
source entier
dans un Zip

@++++++++++++