Version imprimable
Bonjour,
j'ai deux fichiers excel en local.
Un fichier A très complet et un fichier résumé B que je veux envoyer par mail.
J'aimerais qu'un onglet du fichier B fasse un résumé de manière automatique et généré du fichier A mais qu'une fois envoyé il n'y ai pas de références cassée.
Comment cela est-il possible?
Merci d'avance :)
Bonjour,
Une copie de votre feuille source dans un nouveau workbook .... (formats, values et validation) du style ci-dessous
Je ne sais pas si ça peut aider: je copie toutes les valeurs, formats, validation ..... et j'enlève tous les liens résiduels après
Bonne jounrée :)
Code:
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' 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 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
Citation:
Envoyé par vinc_bilb
Merci beaucoup, je vais essayer ça :)
Je m'attendais plutôt à une option de sauvegarde cachée ou quelque chose comme ça plutôt qu'une Macro, mais si ça marche je m'en contenterais :king: