"Auto suppression" de lien hypertexte pour envoi par mail sans références inexistantes

**AoCannaille** · 29/09/2014, 12h14

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

**vinc_bilb** · 29/09/2014, 12h38

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 :

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
 
    ' 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

**AoCannaille** · 29/09/2014, 13h01

Envoyé par vinc_bilb

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 :

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
 
    ' 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

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

"Auto suppression" de lien hypertexte pour envoi par mail sans références inexistantes

Excel

Discussions similaires

Partager

Partager