IdentifiantMot de passe
Loading...
Mot de passe oublié ?Je m'inscris ! (gratuit)
Navigation

Inscrivez-vous gratuitement
pour pouvoir participer, suivre les réponses en temps réel, voter pour les messages, poser vos propres questions et recevoir la newsletter

Excel Discussion :

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


Sujet :

Excel

  1. #1
    Expert confirmé Avatar de AoCannaille
    Inscrit en
    Juin 2009
    Messages
    1 412
    Détails du profil
    Informations forums :
    Inscription : Juin 2009
    Messages : 1 412
    Points : 4 729
    Points
    4 729
    Par défaut "Auto suppression" de lien hypertexte pour envoi par mail sans références inexistantes
    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

  2. #2
    Membre expérimenté
    Homme Profil pro
    Ingénieur développement matériel électronique
    Inscrit en
    Septembre 2013
    Messages
    783
    Détails du profil
    Informations personnelles :
    Sexe : Homme
    Localisation : France, Isère (Rhône Alpes)

    Informations professionnelles :
    Activité : Ingénieur développement matériel électronique
    Secteur : High Tech - Électronique et micro-électronique

    Informations forums :
    Inscription : Septembre 2013
    Messages : 783
    Points : 1 562
    Points
    1 562
    Par défaut Par copie de la sheet du fichier A?
    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
    "Idéalement nous sommes ce que nous pensons. Dans la réalité, nous sommes ce que nous accomplissons." A.Senna
    et n'oubliez-pas de développer des .... sourires ^_^

  3. #3
    Expert confirmé Avatar de AoCannaille
    Inscrit en
    Juin 2009
    Messages
    1 412
    Détails du profil
    Informations forums :
    Inscription : Juin 2009
    Messages : 1 412
    Points : 4 729
    Points
    4 729
    Par défaut
    Citation Envoyé par vinc_bilb Voir le message
    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

Discussions similaires

  1. [PPT-2003] Conserver lien hypertexte pour envoi par mail
    Par zak3r dans le forum Powerpoint
    Réponses: 1
    Dernier message: 09/11/2012, 06h13
  2. [AC-2003] Inserer les codes pour envoi par mail
    Par bomberito dans le forum VBA Access
    Réponses: 1
    Dernier message: 01/02/2012, 22h25
  3. Aide Pour envoi par mail d'un résultat
    Par arno.p dans le forum Général JavaScript
    Réponses: 2
    Dernier message: 18/11/2010, 13h44
  4. [Upload] upload de fichier pour envoi par mail
    Par mdr_cedrick dans le forum Langage
    Réponses: 2
    Dernier message: 26/05/2009, 09h56

Partager

Partager
  • Envoyer la discussion sur Viadeo
  • Envoyer la discussion sur Twitter
  • Envoyer la discussion sur Google
  • Envoyer la discussion sur Facebook
  • Envoyer la discussion sur Digg
  • Envoyer la discussion sur Delicious
  • Envoyer la discussion sur MySpace
  • Envoyer la discussion sur Yahoo