bonsoir a tous ,
voila j utilise un code pour effectuer une sauvegarde en creant un nouveau classeur , tout en verifiant que celui ci n existe pas , le cas echéant me propose de le rempacer ou de stopper .
apres la creation du classeur une feuille est copier a l interieure et le classeur est nomé avant d etre enregistrer.
je voudrai modifier ce code pour que la macro copie un classeur existant appelé copieProduction
une fois copier me nome le classeur copier (sans effacer le modele) et effectue les memes operations precedentes
le code utiliser est :
Sub Prodcopie10()
Dim Rep As String, Fich As String, C As Byte, Cancel, Q As String
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Rep = "C:\Production\Sauvegarde feuille Prod\" ' dossier devant recevoir le nouveau classeur
Sheets(Array("copiejour10")).Copy ' feuille copier dans le classeur d'origine
ActiveSheet.Cells.Copy
ActiveSheet.Cells.PasteSpecial xlValues
Application.CutCopyMode = False
ActiveSheet.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True
JE PENSE QUE C EST ICI QUE JE DEVRAI COPIER LE CLASSEUR EXISTANT "copieProd" SE TROUVANT DANS C:\Production\Sauvegarde feuille Prod\
With ActiveWorkbook 'creation du nouveau classeur
Fich = Range("g7") ' nouveau classeur nomé par la valeur de la cellule g7 de la feuille copiée
For C = 1 To Len(Fich) 'test caractères interdits
If InStr("\/:*?""""<>|", Mid(Fich, C, 1)) > 0 Then
MsgBox "Le nom en F4 ou F6 ou F8 ou F10 contient des caractères interdits !"
Cancel = True
Exit Sub
End If
Next
If Dir(Rep & Fich & ".xls") <> "" Then 'test existence fichier
Q = MsgBox("LA SAUVEGARDE DE CES N° LOTS :" & Fich & " EXISTE DEJA, VOULEZ VOUS LA REMPLACER ?", vbYesNo)
If Q = 7 Then GoTo Ligne1 Else GoTo Ligne2
Else: GoTo Ligne2
End If
Ligne1:
.Close Rep & Fich & ".xls"
'.Close Workbook
Exit Sub
Ligne2:
.SaveAs Rep & Fich & ".xls"
' Dim Nb As Integer
'Nb = 1
'.PrintOut Copies:=Nb, Collate:=True
.Close
End With
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub
MERCI A TOUS DE VOTRE AIDE
amicalement
GHISLAIN
voila j utilise un code pour effectuer une sauvegarde en creant un nouveau classeur , tout en verifiant que celui ci n existe pas , le cas echéant me propose de le rempacer ou de stopper .
apres la creation du classeur une feuille est copier a l interieure et le classeur est nomé avant d etre enregistrer.
je voudrai modifier ce code pour que la macro copie un classeur existant appelé copieProduction
une fois copier me nome le classeur copier (sans effacer le modele) et effectue les memes operations precedentes
le code utiliser est :
Sub Prodcopie10()
Dim Rep As String, Fich As String, C As Byte, Cancel, Q As String
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Rep = "C:\Production\Sauvegarde feuille Prod\" ' dossier devant recevoir le nouveau classeur
Sheets(Array("copiejour10")).Copy ' feuille copier dans le classeur d'origine
ActiveSheet.Cells.Copy
ActiveSheet.Cells.PasteSpecial xlValues
Application.CutCopyMode = False
ActiveSheet.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True
JE PENSE QUE C EST ICI QUE JE DEVRAI COPIER LE CLASSEUR EXISTANT "copieProd" SE TROUVANT DANS C:\Production\Sauvegarde feuille Prod\
With ActiveWorkbook 'creation du nouveau classeur
Fich = Range("g7") ' nouveau classeur nomé par la valeur de la cellule g7 de la feuille copiée
For C = 1 To Len(Fich) 'test caractères interdits
If InStr("\/:*?""""<>|", Mid(Fich, C, 1)) > 0 Then
MsgBox "Le nom en F4 ou F6 ou F8 ou F10 contient des caractères interdits !"
Cancel = True
Exit Sub
End If
Next
If Dir(Rep & Fich & ".xls") <> "" Then 'test existence fichier
Q = MsgBox("LA SAUVEGARDE DE CES N° LOTS :" & Fich & " EXISTE DEJA, VOULEZ VOUS LA REMPLACER ?", vbYesNo)
If Q = 7 Then GoTo Ligne1 Else GoTo Ligne2
Else: GoTo Ligne2
End If
Ligne1:
.Close Rep & Fich & ".xls"
'.Close Workbook
Exit Sub
Ligne2:
.SaveAs Rep & Fich & ".xls"
' Dim Nb As Integer
'Nb = 1
'.PrintOut Copies:=Nb, Collate:=True
.Close
End With
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub
MERCI A TOUS DE VOTRE AIDE
amicalement
GHISLAIN
