Enregistrer une feuille dans un répertoire (et non le classeur entier)

**prog-amateur** · 06/11/2014, 10h16

Bonjour à tous,

J'ai un outil (Userform) presque terminé, incluant un bouton "Save" qui me permet d'enregistrer un fichier à partir de ce qui a été rempli dans un Userform.
Mon problème est qu'il m'enregistre TOUT le classeur.
Je souhaite n'enregistrer qu'une Feuille (par exemple la Feuille 3) dans ce répertoire, comment faire ?
Voici mon code (la partie concernée est en bleu je pense) :

Code :

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

1
2
3
4
5
6
7
8
9
10
Private Sub Save_Click()
For tb = 1 To 7
  Feuil2.Cells(tb, 2) = Me.Controls("TextBox" & tb).Value
  Next
Dim nom As String
    nom = TextBox1 & " -" & TextBox2 & " -" & TextBox3 & " -" & TextBox4
    ThisWorkbook.Sheets(2).Copy
    ActiveWorkbook.SaveCopyAs ActiveWorkbook.Path & "\" & nom & ".xls"
    rep = MsgBox("File registered as : " & nom, vbYes + vbInformation, "Copie sauvegarde classeur")
End Sub

Merci.

**pijaku** · 06/11/2014, 10h58

Bonjour,

Lorsque tu utilises la méthode Copy de l'objet Sheet sans indiquer de paramètre, la feuille est automatiquement copiée dans un nouveau classeur ET ce nouveau classeur devient l'ActiveWorkbook.
Donc, ta ligne de code ici pose souci : ActiveWorkbook.SaveCopyAs ActiveWorkbook.Path & "\" & nom & ".xls"
Notamment la partie en gras.

A ta place, je déclarerais bien, dès le début, ton classeur actif (ThisWorkbook avant copie). Comme ceci :

Code :

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

1
2
3
4
5
6
7
8
9
10
11
12
Private Sub Save_Click()
Dim MonClasseur As Workbook
Set MonClasseur = ThisWorkbook
For tb = 1 To 7
  Feuil2.Cells(tb, 2) = Me.Controls("TextBox" & tb).Value
  Next
Dim nom As String
    nom = TextBox1 & " -" & TextBox2 & " -" & TextBox3 & " -" & TextBox4
    MonClasseur.Sheets(2).Copy
    ActiveWorkbook.SaveCopyAs MonClasseur.Path & "\" & nom & ".xls"
    rep = MsgBox("File registered as : " & nom, vbYes + vbInformation, "Copie sauvegarde classeur")
End Sub

**prog-amateur** · 06/11/2014, 11h48

Merci ta formule marche du tonnerre !
Cependant :
- la feuille 2 est bien enregistrée sur mon répertoire avec le nom que je lui ai donné
- mais une copie de cette feuille 2 reste ouverte et non nommée contrairement à avant. -> Il faut donc la fermer manuellement et refuser de l'enregistrer.

Tu as une idée du souci ? Faut-il ajouter une ligne pour fermer cette copie de Feuille 2 ?

Merci

**pijaku** · 06/11/2014, 12h05

Et bien en fait, il fallait faire la même chose, déclarer une variable Workbook pour y stocker ton classeur créé :
J'espère qu'avec ce code tu comprendras mieux :

Code :

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

1
2
3
4
5
6
7
8
9
10
11
12
13
14
Private Sub Save_Click()
Dim Classeur_Source As Workbook, Classeur_Destination As Workbook
Set Classeur_Source = ThisWorkbook 'classeur initial
For tb = 1 To 7
  Feuil2.Cells(tb, 2) = Me.Controls("TextBox" & tb).Value
Next
Dim nom As String
    nom = TextBox1 & " -" & TextBox2 & " -" & TextBox3 & " -" & TextBox4
    Classeur_Source.Sheets(2).Copy
    Set Classeur_Destination = ActiveWorkbook 'ici le classeur de la copie de la feuille
    ActiveWorkbook.SaveCopyAs Classeur_Source.Path & "\" & nom & ".xls" 'qu'on enregistre sous un autre nom
    Classeur_Destination.Close False 'puis que l'on ferme
    rep = MsgBox("File registered as : " & nom, vbYes + vbInformation, "Copie sauvegarde classeur")
End Sub

**prog-amateur** · 06/11/2014, 13h30

Franck P.,

Tu es le bien. Non seulement, ça fonctionne mais en plus, j'ai compris grâce à toi

**vinc_bilb** · 06/11/2014, 14h03

Bonjour,

Je me permets quelques commentaires:

- Ce qui est proposé marche très bien, tant que la sheet copiée ne fait pas appel à des références internes (Names par exemple), des Hyperlinks, ..... ou des formules utilisant des données sur d'autres feuilles
- Si votre feuille "bénéficie" de ces différents éléments, il convient de les traiter de manière spécificque, sous peine d'avoir des ERR ou Liens dans tous les sens
- Je vous joins un bout de code que vous pouvez réadapter si besoin, surtout la partie

Code :

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

1
2
3
4
5
6
7
8
9
 
    ThisWorkbook.Worksheets(SrcWsname).Copy
(....)
    Set Copyrng = ActiveWorkbook.Worksheets(SrcWsname).UsedRange
    Debug.Print Copyrng.Address
 
    Copyrng.Copy
    Copyrng.PasteSpecial Paste:=xlPasteValues
    Copyrng.PasteSpecial Paste:=xlPasteValidation

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
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
 
Sub EXPORT_ACTIVWSH(Optional Email As Boolean = False)
'=============================================================================
' Copy the active sheet to a new book for publication, email if input parameter is true
 
    Subname = "EXPORT_ACTIVWSH"
 
    Dim Ext_Wbkk  As Workbook, NewWs As Worksheet, WS As Worksheet, Shap As Shape
    Dim SrcWsname As String, Ext_Wbkkname As String, chk_field As String, Msgprompt As String, Msganswer As String
    Dim ValidCopy As Boolean, DelShapHL As Boolean
    Dim RngName As Name, Copyrng As Range
    Dim SavExtrpath As String, Signature As String, Warnmsg As String, InfoLog As String
    Dim FileFmt As XlFileFormat
 
        ' Init
    ThisWorkbook.Activate
    On Error GoTo Err_EXPORT_ACTIVWSH
    Application.ScreenUpdating = False
 
    SrcWsname = ActiveSheet.Name
    SavExtrpath = Range("T_Savpath")(2, 1).Value
    Signature = Range("T_IDENTIF")(6, 2).Value
    Dispmsg = Range("T_OPTIONS")(1, 2)
    DelShapHL = Range("T_OPTIONS")(6, 2)
 
        ' Check the path for the extract
    If CHCK_EXIST_DIR(SavExtrpath) = "False" Then
 
            ' If blank, current directory with a "EXTRACT_DEFAULT" sub-directory creation
        If SavExtrpath = vbNullString Then
 
            SavExtrpath = ThisWorkbook.Path
            SavExtrpath = UPDATE_PATHSEP(SavExtrpath)
            SavExtrpath = UPDATE_PATHSEP(SavExtrpath & "EXTRACT_DEFAULT")
 
            Infomsg = CREATE_DIR(SavExtrpath)
 
        End If
 
        If CHCK_EXIST_DIR(SavExtrpath) = "False" Then
            Warnmsg = "Export folder: " & SavExtrpath & vbCrLf & "=> Folder doesnt exist"
            Msganswer = Msgbox(Warnmsg & vbCrLf & vbCrLf & "Would you like to create it?", vbExclamation + vbYesNo, _
                "WARNING: " & Subname)
 
            If Msganswer = vbYes Then
 
                Infomsg = CREATE_DIR(SavExtrpath)
                Msgbox Infomsg, vbInformation, Subname
 
            Else:
                Warnmsg = Subname & "Select a directory for the extract"
                SavExtrpath = SET_REF_PATH(2, Warnmsg)
 
            End If
 
        End If
 
        Range("T_Savpath")(2, 1).Value = SavExtrpath
 
    End If
 
        ' Set the name of the extracted workbook (radical)
    Call UPDATE_PATHSEP(SavExtrpath)
    Ext_Wbkkname = Range("T_REFER_NAM").Value & "_EXTR_" & SrcWsname
 
        ' Copy the activesheet in a new workbook
    ThisWorkbook.Worksheets(SrcWsname).Copy
 
    Set Ext_Wbkk = ActiveWorkbook
    Set NewWs = ActiveWorkbook.Worksheets(1)
    NewWs.Activate
    ActiveSheet.Unprotect
 
    ' Clean the sheets + links, buttons, protection, references
    Application.DisplayAlerts = False
 
        ' Delete the empty sheets created by default
    For Each WS In Ext_Wbkk.Worksheets
        If (WS.Name) <> SrcWsname Then Worksheets(WS.Name).Delete
    Next WS
 
        ' Delete all the Shaps except the graphs
    If DelShapHL = True Then
 
        For Each Shap In ActiveSheet.Shapes
 
            If Shap.Type <> 3 Then
 
                InfoLog = InfoLog & "Shape Name: " & Shap.Name & vbTab & "Type: " & Shap.Type & vbCrLf
                Shap.Delete
 
            End If
 
        Next Shap
 
        ' Delete links and names
        For Each RngName In ActiveWorkbook.Names
 
 
            Debug.Print "Deleteting range name " & RngName, ActiveWorkbook.Name, RngName.RefersTo
            If InStr(1, RngName.RefersTo, "#REF!") > 0 Then
                InfoLog = InfoLog & "Range Name: " & RngName & vbTab & "Address: " & Range(RngName).Address & vbCrLf
                RngName.Delete
            End If
 
        Next RngName
 
        InfoLog = InfoLog & "Hyperlinks: " & ActiveSheet.Hyperlinks.Count
        ActiveSheet.Hyperlinks.Delete
        InfoLog = "Following items have been deleted: " & vbCrLf & InfoLog
 
    End If
 
    If DelShapHL = False Then
 
        InfoLog = InfoLog & ActiveSheet.Shapes.Count & " shapes not deleted" & vbCrLf
        InfoLog = InfoLog & ActiveWorkbook.Names.Count & " named ranges not deleted" & vbCrLf
        InfoLog = InfoLog & ActiveSheet.Hyperlinks.Count & " hyperlinks not deleted"
 
    End If
 
    Msgbox InfoLog, vbInformation, Subname
 
           ' Set the inputs for copy
    Set Copyrng = ActiveWorkbook.Worksheets(SrcWsname).UsedRange
    Debug.Print Copyrng.Address
 
    Copyrng.Copy
    Copyrng.PasteSpecial Paste:=xlPasteValues
    'Range(Copyrng.Address).PasteSpecial Paste:=xlPasteFormats
    Copyrng.PasteSpecial Paste:=xlPasteValidation
    Range("A1").Select
 
        ' Set the source file as hyperlink
    Range("C4").Value = "Extract from"
    ActiveSheet.Hyperlinks.Add Anchor:=Range("D4"), _
        Address:=ThisWorkbook.FullNameURLEncoded, _
        TextToDisplay:=ThisWorkbook.Name
 
        ' Get the extension
    Ext_Wbkkname = Ext_Wbkkname & SET_DEF_FILE_EXT(Ext_Wbkk)
    FileFmt = SET_DEF_FILE_FMT(Ext_Wbkk)
 
        ' Check if the worlbook for extract is already open, propose to close it or Abort
    If IS_WBK_OPEN(Ext_Wbkkname) = True Then
        Msgprompt = "The workbook " & Ext_Wbkkname & " is already open" & _
        vbCrLf & "Would you like to close it?" & vbCrLf & vbCrLf & "Aborting if No!"
        Msganswer = Msgbox(Msgprompt, vbExclamation + vbYesNo, Subname)
        If Msganswer = vbYes Then
            Application.DisplayAlerts = False
            Workbooks(Ext_Wbkkname).Close SaveChanges:=True
        Else:
            End 'Abort
        End If
    End If
 
        ' Save it
    Debug.Print Ext_Wbkk.Name, SavExtrpath, Ext_Wbkkname, FileFmt
 
            ' Prompt if applicable
    Msgprompt = "Exporting sheet in file " & Ext_Wbkkname & vbCrLf & "Path " & SavExtrpath & _
        vbCrLf & vbCrLf & "=> CONFIRM?"
    Msganswer = Msgbox(Msgprompt, vbYesNo, Subname)
 
    If Msganswer <> vbNo Then
 
        Application.DisplayAlerts = False
 
        Ext_Wbkk.SaveAs Filename:=SavExtrpath & Ext_Wbkkname, FileFormat:=FileFmt, _
            CreateBackup:=False, AddToMru:=True, ReadOnlyRecommended:=False
        Ext_Wbkk.Saved = True
 
        Application.DisplayAlerts = True
    End If
 
        ' Email and propose to delete
    If Email = True Then
 
        Call SEND_WBK(Ext_Wbkk, Signature)
 
        Msgprompt = "Would you like to delete this workbook from disk? " & vbCrLf & _
            Ext_Wbkk.FullName
        Msganswer = Msgbox(Msgprompt, vbYesNo, Subname)
 
        If Msganswer = vbYes Then
            ThisWorkbook.Activate
            Workbooks(Ext_Wbkkname).Close SaveChanges:=False
            Kill (SavExtrpath & Ext_Wbkkname)
        End If
 
    End If
 
        ' Closure, propose to close if still open
    If IS_WBK_OPEN(Ext_Wbkkname) = True Then
        Msgprompt = "Would you like to close this extract workbook?"
        Msganswer = Msgbox(Msgprompt, vbYesNo, Subname)
        If Msganswer <> vbNo Then Workbooks(Ext_Wbkkname).Close SaveChanges:=True
    End If
 
    Application.EnableEvents = True
    Application.DisplayAlerts = True
 
    If Dispmsg = True And Infomsg <> vbNullString Then
        Msgbox Infomsg, vbInformation, Subname
    End If
 
 
Err_EXPORT_ACTIVWSH:
    If Err.Number <> 0 Then
        Msgprompt = "There is an error during the copy" & vbCrLf & Err.Description
        Msgbox Msgprompt, vbCritical, Subname
        Application.ScreenUpdating = True
        Application.EnableEvents = True
        Application.DisplayAlerts = True
        End
    End If
 
End Sub

Bonne journée

Enregistrer une feuille dans un répertoire (et non le classeur entier)

Macros et VBA Excel

Discussions similaires

Partager

Partager