Ceci est une page optimisée pour les mobiles. Cliquez sur ce texte pour afficher la vraie page.

XL 2010 Localiser LinkSources dans l'activeworkbook..

Créer une discussion

Boostez vos compétences Excel avec notre communauté !

Rejoignez Excel Downloads, le rendez-vous des passionnés où l'entraide fait la force. Apprenez, échangez, progressez – et tout ça gratuitement ! 👉 Inscrivez-vous maintenant !

S'inscrire

vgendron

XLDnaute Barbatruc
Bonjour à toutes et tous,

Me voici avec un nouveau casse-tête 🙃

Vous avez surement tous été confrontés un jour à ce message dès l'ourverture de votre fichier excel

"Ce classeur comporte des liaisons avec une ou plusieurs sources externes...." Mettre à jour - Ne pas mette à jour - aide"
bien souvent , on fait "Ne pas mettre à jour" pour etre tranquille.. mais le message reviendra la prochaine fois..
donc, on finit par décider de faire "Mettre à jour".. et la....
il ne trouve pas la fameuse source.. donc.. on choisit "Modifier les liaisons"
et il vous sort une jolie liste avec tout un tas d'informations SAUF celle qui nous interresse : QUI dans ce classeur fait appel à ces fichiers externes ??

et le bouton Rompre liaison ne donne rien !!!
bref.. tout un tas de clics.. pour .... 0 résultat !!

j'ai donc cherché comment supprimer ces liens.. avec la macro ci dessous

VB: 
Sub SupprimerLiaisons()
Dim Liaisons As Variant
Dim LiaisonsTrouvee As Long
Liaisons = ActiveWorkbook.LinkSources(Type:=xlLinkTypeExcelLinks)

If IsEmpty(Liaisons) = True Then Exit Sub

For LiaisonsTrouvee = 1 To UBound(Liaisons)
    MsgBox Liaisons(LiaisonsTrouvee)
ActiveWorkbook.BreakLink _
    Name:=Liaisons(LiaisonsTrouvee), _
    Type:=xlLinkTypeExcelLinks

Next LiaisonsTrouvee

End Sub

OK.. ca marche très bien.. mais.. je ne sais toujours pas OU dans mon fichier, cette liaison apparait...
si ca se trouve..je viens de supprimer des liaisons importantes???
donc THE question
sauriez vous comment localiser cette liaison avant de la supprimer??

Merci et bonne journée :-D
 
Trier par date Trier par votes
Bonjour à tous

copiez ce qui suit et collez-le dans un module standard


VB: 
Option Explicit

Public Sub GetreferenceExterne()

Dim xSheet As Worksheet
Dim xRg As Range, rng As Range
Dim xCell As Range
Dim xCount As Long
Dim xLinkArr() As String
Dim lastrow As Long

Application.ScreenUpdating = False
Application.DisplayAlerts = False
On Error Resume Next

For Each xSheet In Application.ThisWorkbook.Worksheets
    Set xRg = xSheet.UsedRange.SpecialCells(xlCellTypeFormulas)
        If xRg Is Nothing Then GoTo NextStep
        For Each xCell In xRg
            If InStr(1, xCell.Formula, "[") > 0 Then
                xCount = xCount + 1
                ReDim Preserve xLinkArr(1 To 2, 1 To xCount)
                xLinkArr(1, xCount) = xCell.Address(, , , True)
                xLinkArr(2, xCount) = "'" & xCell.Formula
            End If
        Next xCell
NextStep:
Next xSheet
On Error GoTo 0
     If sheetExiste("référence externe") Then
        If xCount > 0 Then
'            On Error Resume Next
'            Application.ThisWorkbook.Worksheets("référence externe").Delete
'            On Error GoTo 0
'            Sheets.Add(Sheets(1)).Name = "référence externe"
            Application.ThisWorkbook.Worksheets("référence externe").Select
            lastrow = Application.ThisWorkbook.Worksheets("référence externe").Cells(Application.ThisWorkbook.Worksheets("référence externe").Rows.Count, "A").End(xlUp).Row
            Debug.Print lastrow
            Range("A1:B" & lastrow).ClearContents
            Range("A1").Resize(, 2).Value = Array("Localisation exacte: Workbook name & sheet name & col / row", "Links: référence externe")
            Range("A1").Resize(, 2).Font.Name = "Times New Roman"
            Range("A1").Resize(, 2).Font.Color = RGB(48, 84, 150)
            Range("A1").Resize(, 2).Font.Size = 11
            Range("A1").Resize(, 2).HorizontalAlignment = xlCenter
            Range("A1").Resize(, 2).Font.Bold = True
            Range("A1").Resize(, 2).Interior.Color = RGB(242, 242, 242)
            Range("A2").Resize(UBound(xLinkArr, 2), UBound(xLinkArr, 1)).Value = Application.Transpose(xLinkArr)
            lastrow = Application.ThisWorkbook.Worksheets("référence externe").Cells(Application.ThisWorkbook.Worksheets("référence externe").Rows.Count, "A").End(xlUp).Row
            Set rng = Application.ThisWorkbook.Worksheets("référence externe").Range("A1:B" & lastrow)
            rng.RemoveDuplicates Columns:=2, Header:=xlNo
            Columns("A:B").AutoFit
            GoTo resumeExit:
        Else
            MsgBox "• Aucun lien de référence externe trouvé!", vbInformation, "Information!"
            GoTo resumeExit:
        End If
    Else
        If xCount > 0 Then
            Sheets.Add(Sheets(1)).Name = "référence externe"
            Range("A1").Resize(, 2).Value = Array("Localisation exacte: Workbook name & sheet name & col / row", "Links: référence externe")
            Range("A1").Resize(, 2).Font.Name = "Times New Roman"
            Range("A1").Resize(, 2).Font.Color = RGB(48, 84, 150)
            Range("A1").Resize(, 2).Font.Size = 11
            Range("A1").Resize(, 2).HorizontalAlignment = xlCenter
            Range("A1").Resize(, 2).Font.Bold = True
            Range("A1").Resize(, 2).Interior.Color = RGB(242, 242, 242)
            Range("A2").Resize(UBound(xLinkArr, 2), UBound(xLinkArr, 1)).Value = Application.Transpose(xLinkArr)
            lastrow = Application.ThisWorkbook.Worksheets("référence externe").Cells(Application.ThisWorkbook.Worksheets("référence externe").Rows.Count, "A").End(xlUp).Row
            Set rng = Application.ThisWorkbook.Worksheets("référence externe").Range("A1:B" & lastrow)
            rng.RemoveDuplicates Columns:=2, Header:=xlNo
            Columns("A:B").AutoFit
        Else
            MsgBox "• Aucun lien de référence externe trouvé!", vbInformation, "Information!"
        End If
     End If

resumeExit:
    On Error GoTo 0
    If Not xRg Is Nothing Then Set xRg = Nothing
    If Not rng Is Nothing Then Set rng = Nothing
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True

End Sub

Function sheetExiste(sheetName As String) As Boolean

Dim i As Integer

sheetExiste = False

For i = 1 To Application.ActiveWorkbook.Sheets.Count
    If Application.ActiveWorkbook.Sheets(i).Name = sheetName Then
        sheetExiste = True
        Exit For
    End If
Next

End Function




exemple pour appeler la macro c'est: Call GetreferenceExterne
 
Dernière édition:
Vote positif 0 Vote négatif
Salut Rhysand

Merci pour ce code:
si je ne dis pas de betise, il regarde le contenu des formules dans tout le classeur
et s'il trouve le caractère "[", il en déduit qu'il s'agit d'une liaison externe
correct ?
c'est donc l'équivalent du Ctrl+F


dans ce cas: ca ne suffit pas: en effet, ton code me retourne 0 liaison
alors que le code que j'ai posté au début m'indique toujours que j'ai deux liaisons..

j'ai lu que les liaisons pouvaient aussi etre dans le gestionnaire de nom (j'ai déjà vérifié.. elles ne sont pas la)
ca peut aussi etre dans des graphes ou meme des MFC....
 
Vote positif 0 Vote négatif
essayez le code suivant, tous les liens seront rompus


mettre dans un module standard

VB: 
Option Explicit

Public Sub removeLinks()

Dim link

If Not IsEmpty(Application.ThisWorkbook.LinkSources(xlExcelLinks)) Then
      For Each link In Application.ThisWorkbook.LinkSources(xlExcelLinks)
           Application.ThisWorkbook.BreakLink link, xlLinkTypeExcelLinks
      Next link
End If

End Sub


exemple pour appeler la macro c'est: Call removeLinks
 
Vote positif 0 Vote négatif
Re..
pour info pour ceux que ca interressent
j'ai trouvé sur le net un add in excel (développeur Laurent Longre ??) qui fait très bien le boulot
et qui m'a permis d'identifier la centaine de MFC en cause...


attention: il s'agit d'un XLAm
de ce que j'ai pu voir.. il est bien fait puisque le module complémentaire se désinstalle à sa fermeture.
 
Vote positif 0 Vote négatif
Je m'excuse pour le retard dans la réponse, et quelque chose comme ça?


VB: 
Option Explicit

Public Sub GetreferenceExterne()

Dim xSheet As Worksheet
Dim xRg As Range, rng As Range
Dim xCell As Range
Dim xCount As Long
Dim xLinkArr() As String
Dim lastrow As Long
Dim ArrOutput As Variant
Dim xLink As String
 
Application.ScreenUpdating = False
Application.DisplayAlerts = False
On Error Resume Next

For Each xSheet In Application.ThisWorkbook.Worksheets
    Set xRg = xSheet.UsedRange.SpecialCells(xlCellTypeFormulas)
        If xRg Is Nothing Then GoTo NextStep
        For Each xCell In xRg
            If InStr(1, xCell.Formula, "[") > 0 Then
                xCount = xCount + 1
                ReDim Preserve xLinkArr(1 To 4, 1 To xCount)
                xLinkArr(1, xCount) = xCell.Address(, , , True)
                xLinkArr(2, xCount) = "'" & xCell.Formula
                xLinkArr(3, xCount) = xCell.Value
                
                xLink = VBA.Replace(xCell.Formula, "=HYPERLINK('", "")
                ArrOutput = VBA.Split(xLink, "]")
                xLink = ArrOutput(0)
                xLink = VBA.Replace(xLink, "[", "")
                
                If Not FileExists(xLink) = True Then xLinkArr(4, xCount) = "broken link" Else xLinkArr(4, xCount) = "Active link"
                
            End If
        Next xCell
NextStep:
Next xSheet
On Error GoTo 0
     If sheetExiste("référence externe") Then
        On Error Resume Next
        Application.ThisWorkbook.Worksheets("référence externe").Delete
        On Error GoTo 0
        Sheets.Add(Sheets(1)).Name = "référence externe"
     Else
        If xCount > 0 Then Sheets.Add(Sheets(1)).Name = "référence externe"
     End If
        If xCount > 0 Then
            Range("A1").Resize(, 4).Value = Array("Localisation exacte: Workbook name & sheet name & col / row", "Links: référence externe", "Cell value", "active or broken")
            Range("A1").Resize(, 4).Font.Name = "Times New Roman"
            Range("A1").Resize(, 4).Font.Color = RGB(48, 84, 150)
            Range("A1").Resize(, 4).Font.Size = 11
            Range("A1").Resize(, 4).HorizontalAlignment = xlCenter
            Range("A1").Resize(, 4).Font.Bold = True
            Range("A1").Resize(, 4).Interior.Color = RGB(242, 242, 242)
            Range("A2").Resize(UBound(xLinkArr, 2), UBound(xLinkArr, 1)).Value = Application.Transpose(xLinkArr)
            lastrow = Application.ThisWorkbook.Worksheets("référence externe").Cells(Application.ThisWorkbook.Worksheets("référence externe").Rows.Count, "A").End(xlUp).Row
            Set rng = Application.ThisWorkbook.Worksheets("référence externe").Range("A1:D" & lastrow)
            rng.RemoveDuplicates Columns:=2, Header:=xlNo
            Columns("A:D").AutoFit
        Else
            MsgBox "• Aucun lien de référence externe trouvé!", vbInformation, "Information!"
        End If
    
resumeExit:
    On Error GoTo 0
    If Not xRg Is Nothing Then Set xRg = Nothing
    If Not rng Is Nothing Then Set rng = Nothing
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
End Sub

Private Function sheetExiste(sheetName As String) As Boolean

Dim i As Integer

sheetExiste = False

For i = 1 To Application.ActiveWorkbook.Sheets.Count
    If Application.ActiveWorkbook.Sheets(i).Name = sheetName Then
        sheetExiste = True
        Exit For
    End If
Next

End Function

Private Function FileExists(FilePath As String) As Boolean

Dim str As String
str = ""

On Error Resume Next
str = Dir(FilePath)
On Error GoTo 0

If str = "" Then
    FileExists = False
Else
    FileExists = True
End If
    
End Function
 
Vote positif 0 Vote négatif
Hello Rhysand

Je vois que la modif apportée vérifie que les cibles des liens hypertextes sont vérifiées. C'est OK

mais comme dit plus haut, ca ne suffit pas.. il faut aussi chercher dans les graphes, les tables pivot (quand il y en a) et les MFC et le gestionnaire de nom... bref.. faut chercher partout...:-D

l' Addin trouvé, me donne tout ca... je ne vais pas réinventer la roue.. donc, je vais le garder précieusement à porter de classeur !

En tout cas merci.
 
Vote positif 0 Vote négatif
Bonsoir à tous


Je réponds hors du temps, pas beaucoup de temps pour le moment !!!

juste pour laisser une idée, encore en construction et adaptation



VB: 
Option Explicit


Public Sub getAllHyperlinks()

Dim xSheet As Worksheet, refSheet As Worksheet, countSheet As Worksheet
Dim i As Integer
Dim xCell As Range
Dim sLink As String, xLink As String, sUrl As String
Dim strArray As Variant, xLinkArr As Variant, ArrOutput As Variant
Dim shp As Shape

If sheetExiste("référence externe") Then
    Application.DisplayAlerts = False
    On Error Resume Next
    Application.ThisWorkbook.Worksheets("référence externe").Delete
    On Error GoTo 0
    Application.DisplayAlerts = True
End If

Set refSheet = Sheets.Add

With refSheet
    .Name = ("référence externe")
    .Range("A1").Resize(, 5).Value = Array("Cell value/shape name", "Localisation exacte: Workbook name & sheet name & col / row", "Hyperlinks référence/shape type", "Links: référence externe", "active or broken")
    .Range("A1").Resize(, 5).Font.Name = "Times New Roman"
    .Range("A1").Resize(, 5).Font.Color = RGB(48, 84, 150)
    .Range("A1").Resize(, 5).Font.Size = 11
    .Range("A1").Resize(, 5).HorizontalAlignment = xlCenter
    .Range("A1").Resize(, 5).Interior.Color = RGB(242, 242, 242)
End With

i = 0

For Each countSheet In Application.ThisWorkbook.Worksheets
    If countSheet.Name = refSheet.Name Then GoTo nextSheet:
    countSheet.Select
    Set xSheet = ActiveSheet
    
    For Each xCell In xSheet.UsedRange
        On Error Resume Next
        sLink = xCell.Hyperlinks(1).SubAddress
        If Err = 0 Then
            If VBA.Left(xCell.Formula, 4) = "http" Or VBA.Left(xCell.Formula, 3) = "www" Then
                refSheet.Range("A2").Offset(i, 0) = xCell.Value
                refSheet.Range("B2").Offset(i, 0) = xCell.Address(, , , True)
                refSheet.Range("C2").Offset(i, 0) = "Url:  " & xCell.Hyperlinks(1).Address
                refSheet.Range("D2").Offset(i, 0) = "'" & xCell.Formula
                sUrl = xCell.Formula
                refSheet.Range("E2").Offset(i, 0) = checkUrl(sUrl)
                i = i + 1
            Else
                refSheet.Range("A2").Offset(i, 0) = xCell.Value
                refSheet.Range("B2").Offset(i, 0) = xCell.Address(, , , True)
                refSheet.Range("C2").Offset(i, 0) = xCell.Hyperlinks(1).Address
                refSheet.Range("D2").Offset(i, 0) = "'" & xCell.Formula
                refSheet.Range("E2").Offset(i, 0) = "'" & "???"
                i = i + 1
            End If
        Else
            If VBA.Left(xCell.Formula, 11) = "=HYPERLINK(" Then
                strArray = VBA.Split(xCell.Formula, Chr(34))
                refSheet.Range("A2").Offset(i, 0) = xCell.Value
                refSheet.Range("B2").Offset(i, 0) = xCell.Address(, , , True)
                refSheet.Range("C2").Offset(i, 0) = strArray(1)
                refSheet.Range("D2").Offset(i, 0) = "'" & xCell.Formula
                xLink = VBA.Replace(xCell.Formula, "=HYPERLINK('", "")
                ArrOutput = VBA.Split(xLink, "]")
                xLink = ArrOutput(0)
                xLink = VBA.Replace(xLink, "[", "")
                If Not FileExists(xLink) = True Then refSheet.Range("E2").Offset(i, 0) = "Broken link" Else refSheet.Range("E2").Offset(i, 0) = "Active link"
                i = i + 1
            End If
        End If
        On Error GoTo 0
    Next xCell
    
    For Each shp In xSheet.Shapes
        xLink = ""
        On Error Resume Next
        xLink = shp.Hyperlink.Address
        On Error GoTo 0
        If xLink <> "" Then
            refSheet.Range("A2").Offset(i, 0) = "shape name: " & shp.Name
            refSheet.Range("B2").Offset(i, 0) = "[" & Application.ThisWorkbook.Name & "]" & xSheet.Name & "; shape top: " & shp.Top & "; shape left: " & shp.Left
            refSheet.Range("C2").Offset(i, 0) = "shape info.:    type: " & determineShapeType(shp.Type)
            refSheet.Range("D2").Offset(i, 0) = xLink
            refSheet.Range("E2").Offset(i, 0) = "'" & "???"
            i = i + 1
        End If
    Next shp
nextSheet:
Next countSheet
 
refSheet.Columns("A:E").AutoFit
refSheet.Select

If Not refSheet Is Nothing Then Set refSheet = Nothing
If Not xSheet Is Nothing Then Set xSheet = Nothing

End Sub

Private Function sheetExiste(sheetName As String) As Boolean

Dim i As Integer

sheetExiste = False

For i = 1 To Application.ActiveWorkbook.Sheets.Count
    If Application.ActiveWorkbook.Sheets(i).Name = sheetName Then
        sheetExiste = True
        Exit For
    End If
Next

End Function

Private Function FileExists(FilePath As String) As Boolean

Dim str As String
str = ""

On Error Resume Next
str = Dir(FilePath)
On Error GoTo 0

If str = "" Then
    FileExists = False
Else
    FileExists = True
End If
    
End Function

Private Function determineShapeType(shpType As MsoShapeType) As String

Select Case shpType
    Case "-2"
        determineShapeType = "Mixed shape type"
    Case 1
        determineShapeType = "AutoShape"
    Case 2
        determineShapeType = "Callout"
    Case 3
        determineShapeType = "Chart"
    Case 4
        determineShapeType = "Comment"
    Case 5
        determineShapeType = "FreeForm"
    Case 6
        determineShapeType = "Group"
    Case 7
        determineShapeType = "Embedded OLE object"
    Case 8
        determineShapeType = "Form Control"
    Case 9
        determineShapeType = "Line"
    Case 10
        determineShapeType = "Linked OLE object"
    Case 11
        determineShapeType = "Linked Picture"
    Case 12
        determineShapeType = "OLE Control object"
    Case 13
        determineShapeType = "Picture"
    Case 14
        determineShapeType = "Placeholder"
    Case 15
        determineShapeType = "Text effect"
    Case 16
        determineShapeType = "Media"
    Case 17
        determineShapeType = "Text box"
    Case 18
        determineShapeType = "Script anchor"
    Case 19
        determineShapeType = "Table"
    Case 20
        determineShapeType = "Canvas"
    Case 21
        determineShapeType = "Diagram"
    Case 22
        determineShapeType = "Ink"
    Case 22
        determineShapeType = "Ink"
    Case 23
        determineShapeType = "Ink comment"
    Case 24
        determineShapeType = "SmartArt graphic"
    Case 26
        determineShapeType = "Web video"
    Case 27
        determineShapeType = "Content Office Add-in"
    Case 28
        determineShapeType = "Graphic"
    Case 29
        determineShapeType = "Linked graphic"
    Case 30
        determineShapeType = "3D model"
    Case 31
        determineShapeType = "Linked 3D model"
    Case Else
        determineShapeType = "¿unknown?"
End Select

End Function

Private Function checkUrl(xUrl As String) As String

Dim xDetermine As Object
Dim feedback As Variant

checkUrl = "Url is Broken"

On Error GoTo resumeOut:
Set xDetermine = CreateObject("WinHttp.WinHttpRequest.5.1")

With Request
  .Open "GET", xUrl, False
  .Send
  feedback = .StatusText
End With

If Not xDetermine Is Nothing Then Set xDetermine = Nothing
If feedback = "OK" Then checkUrl = "Url is Active"

Exit Function
resumeOut:
    ' Error: broken or not checked
End Function
 
Dernière édition:
Vote positif 0 Vote négatif
Bonsour® rendre à César etc ...
 
Vote positif 0 Vote négatif
Identifiez-vous ou inscrivez-vous pour participer.
Rejoins nos membres "Supporter XLD" et booste ton expérience Excel !
- Navigue sans publicité
- Accède à Cléa, notre assistante IA experte Excel... et pas que...
- Profite de fonctionnalités exclusives
Ton soutien permet à Excel Downloads de rester 100% gratuit et de continuer à rassembler les passionnés d'Excel.
Je deviens Supporter XLD

Discussions similaires

P
  • Question Question
copier une feuille dans autre classeur en supprimant les macros
Réponses
4
Affichages
1 K
PIERRE02
P
S
  • Question Question
XL 2010 VBA - Refresh d'une Listbox pendant une macro
Réponses
1
Affichages
3 K
sousou
S
  • Question Question
XL 2016 Pousser les données de l'Userform dans une nouvelle ligne de tableau
Réponses
8
Affichages
1 K
Sparfell29
S
A
  • Question Question
Macro - centrer une image importé dans une cellule
Réponses
0
Affichages
2 K
Anarhim
A
Y
  • Question Question
Macro excel pour mise à jour de liaisons
Réponses
2
Affichages
2 K
STephane
S
C
  • Question Question
Suppression des liaisons impossible ?
Réponses
12
Affichages
8 K
fifi
F
L
  • Question Question
liaison classeur/msge d'avertissemt
Réponses
6
Affichages
1 K
lio
L
Menu
Connexion
S'inscrire
Les cookies sont requis pour utiliser ce site. Vous devez les accepter pour continuer à utiliser le site. En savoir plus…