Discussion :

[jordan973]

Bonjour,

Étant débutant en Visual Basic j'ai crée un petit code qui me sauvegarde, une feuille d'un classeur à un instant T (lors de l'appel de la fonction).
Cependant, je ne comprend pas pourquoi, malgré que le code fonctionne correctement, il me crée aussi un classeur vierge de 3 pages nommé classeur1, classeur2, classeur(n+1), etc à chaque fois que ce code est lancée.
Évidemment, je n'est pas l'intérêt à conservé des fichiers EXCEL vierges.

Si l'un d'entre vous peut me donner la solution à ce problème....
Car mois, j'ai beau cherché, je n'y comprend rien.

Voici le code :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
 
Function SauvMatrice()
    Dim NomInterv As String, chemin As String
    NomInterv = Range("A65536").End(xlUp).Text & "_" & Format(Date, "mm_yy")
    Dim MyPath As String
    Dim myName As String
    Dim FichierSource As String
    Dim Sauvegarde As String
    Dim AnneActuel As String
    AnneActuel = "Année " & Format(Date, "yyyy")
 
Application.ScreenUpdating = False
FichierSource = ActiveWorkbook.Name
MyPath = ActiveWorkbook.Path
myName = Format(Date, "mmm_yyyy")
If Dir(MyPath & "\" & AnneActuel, vbDirectory) <> "" Then  'On teste l'existence du répertoire
 
Else
    MkDir MyPath & "\" & AnneActuel
End If
 
 
If Dir(MyPath & "\" & AnneActuel & "\" & myName, vbDirectory) <> "" Then 'On teste l'existence du répertoire
 
Else
    MkDir MyPath & "\" & AnneActuel & "\" & myName
End If
 
Application.DisplayAlerts = False
'Sauvegarde une copie de la matrice (demande) avec pour nom le numéro de demande
Set NewBook = Workbooks.Add
NewBook.SaveAs Filename:=MyPath & "\" & AnneActuel & "\" & myName & "\" & NomInterv, FileFormat:=xlNormal, Password:="", WriteResPassword:="", ReadOnlyRecommended:=False, CreateBackup:=False
Sauvegarde = ActiveWorkbook.Name
Workbooks(FichierSource).Activate
Sheets("Matrice").Select
Sheets("Matrice").PrintOut Copies:=2
Sheets("Matrice").Copy before:=Workbooks(Sauvegarde).Sheets(1)
Sheets("Feuil3").Select
Application.DisplayAlerts = False
ActiveWindow.SelectedSheets.Delete
Sheets("Feuil2").Select
Application.DisplayAlerts = False
ActiveWindow.SelectedSheets.Delete
Sheets("Feuil1").Select
Application.DisplayAlerts = False
ActiveWindow.SelectedSheets.Delete
Workbooks(Sauvegarde).Save
Workbooks(Sauvegarde).Close
Sheets("Listing").Activate
ActiveWorkbook.Save
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Function

[mercatog]

Regarde comme ceci, j'ai retouché le code, j'ai pas testé

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
Sub SauvMatrice()
Dim FichierSource As Workbook, NewBook As Workbook
Dim NomInterv As String, AnneActuel As String, MyPath As String, myName As String
 
Application.ScreenUpdating = False
AnneActuel = "Année " & Format(Date, "yyyy")
NomInterv = Range("A65536").End(xlUp).Text & "_" & Format(Date, "mm_yy")
Set FichierSource = ThisWorkbook
MyPath = FichierSource.Path
myName = Format(Date, "mmm_yyyy")
If Dir(MyPath & "\" & AnneActuel, vbDirectory) = "" Then MkDir MyPath & "\" & AnneActuel    'On teste l'existence du répertoire
If Dir(MyPath & "\" & AnneActuel & "\" & myName, vbDirectory) = "" Then MkDir MyPath & "\" & AnneActuel & "\" & myName   'On teste l'existence du répertoire
 
Application.DisplayAlerts = False
'Sauvegarde une copie de la matrice (demande) avec pour nom le numéro de demande
Set NewBook = Workbooks.Add(1)
With FichierSource.Sheets("Matrice")
    .PrintOut Copies:=2
    .Copy before:=NewBook.Sheets(1)
End With
Set FichierSource = Nothing
 
With NewBook
    .Sheets("Feuil1").Delete
    .SaveAs Filename:=MyPath & "\" & AnneActuel & "\" & myName & "\" & NomInterv, FileFormat:=xlNormal, Password:="", WriteResPassword:="", ReadOnlyRecommended:=False, CreateBackup:=False
    .Close
End With
Set NewBook = Nothing
Application.DisplayAlerts = True
End Sub