liaison fichier

J

jamespatagueul

XLDnaute Occasionnel
Bonjour à Tous,

J'ai 4 fichiers qui sont liées entre eux. (fichier 1 . 2. 3 & 4 par exemple)
la structure est la suivante :
dossier archive avec a l’intérieur: fichier 1, dossier 2
dans le dossier 2 : fichier 2 . 3 & 4.

Tous fonctionne parfaitement, cependant, je duplique 3 fois cette structure, donc le dossier 2 change de nom, sauf les fichiers.(mais qui pourrai changer de nom)

Je cherche à faire en sort que, lors du dupliquage des dossiers et fichiers originaux, je n'ai pas à mettre a jours la source (modifier les liaisons), qui forcement change d'emplacement.(dossier .2 .3 .4)

J'ai pense a "indirect" mais plus de 600 cellules à mettre a jour.
peux être en VBA.

Je cherche une piste.

Merci
 
Trier par date Trier par votes
Dranreb

Dranreb

XLDnaute Barbatruc
Mais s'il y a plusieurs liens, comment on peut savoir quel lien est à changer ?
J'ai essayé en notant le nom de fichier de A1 dans une variable avant qu'on ne la change, mais ce n'est pas le nom de fichier d'un lien existant.
En effet il y a INVENTAIRE ANNUEL.xlsm en A1 mais il n'y a qu'un lien vers
autre chose : INVENTAIRE ANNUELLE MAISON.xlsm
 
Vote positif 0 Vote négatif
Dranreb

Dranreb

XLDnaute Barbatruc
Bon, alors je note dans ma variable AncNomFic et dans la cellule A1 le nom trouvé dans la formule en B3.
Essayez comme ça, dans le module de la feuille cette fois :
VB: 
Option Explicit
Private AncNomFic As String
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
   If Target.Address <> "$A$1" Then Exit Sub
   AncNomFic = Split(Split(Me.[B4].Formula, "[")(1), "]")(0)
   Application.EnableEvents = False
   Target.Value = AncNomFic
   Application.EnableEvents = True
   End Sub
Private Sub Worksheet_Change(ByVal Target As Range)
   Dim NomFic As String, TLkSrc(), N As Long, ALien As String, TSplL() As String, NLien As String, P As Long
   If Target.Address <> "$A$1" Then Exit Sub
   NomFic = Target.Value
   If NomFic = AncNomFic Then Exit Sub
     TLkSrc = ThisWorkbook.LinkSources
      If Err Then Exit Sub
      On Error GoTo 0
      For N = 1 To UBound(TLkSrc)
         ALien = TLkSrc(N)
         TSplL = Split(ALien, "\")
         P = UBound(TSplL)
         If TSplL(P) = AncNomFic Then
            TSplL(P) = NomFic
            NLien = Join(TSplL, "\")
            If NLien <> ALien Then
               If MsgBox("Lien """ & ALien & """ à" _
                  & vbLf & "Changer """ & NLien & """ ?", _
                  vbYesNo + vbExclamation, Me.Name) = vbYes Then
                  On Error Resume Next
                  ThisWorkbook.ChangeLink ALien, NLien, xlLinkTypeExcelLinks
                  If Err Then MsgBox "Err " & Err & " en tentant de changer le lien." _
                     & vbLf & Err.Description, vbCritical, Me.Name
                  On Error GoTo 0: End If: End If: End If: Next N
   AncNomFic = NomFic
   End Sub
 
Vote positif 0 Vote négatif
J

jamespatagueul

XLDnaute Occasionnel
Bernard,

merci.
Quant j'ouvre le fichier, et quant le nom de"inventaire...xlsm" a changer, je modifie le nom en A1 et les formules se mettent à jours.
Super.

Je vais chercher pour bloquer les message de mise a jour des lien par un message de vérification du nom du fichier concerner.

Merci encore malgré mes mauvaise explication.
 
Vote positif 0 Vote négatif
J

jamespatagueul

XLDnaute Occasionnel
Dranreb,
pour mon premier fichier, ça fonctionne impeccable avec la macro dans la feuil et adaptation de la cellule pour la formule.

Cependant dans les autres fichiers, pour les autres formules qui sont comme suit, ='C:\COMPAGNONS\AAA\BBB\[BASE INVENTAIRE.xlsm]suivie prix'!B8

La macro dans thisworkbook ne sort qu'une parti de l'adresse du fichier ='C:\COMPAGNONS\AAA, mais il faut que j'aille jusqu'a ='C:\COMPAGNONS\AAA\BBB car le fichier BASE INVENTAIRE.xlsm est dans ce dossier.
sachant que ='C:\COMPAGNONS\AAA\BBB peux être ='E:\xxx\yyy\zzz ou ="'D:xxx\rrr et le nom [BASE INVENTAIRE.xlsm] peux changer
La seule chose fixe c'est suivie prix'!B8.

Merci de votre aide en tous les cas.
 
Vote positif 0 Vote négatif
Dranreb

Dranreb

XLDnaute Barbatruc
Voici deux procédures susceptible de changer d'autres liens :
VB: 
Sub ChangerLiens(ByVal Ancien As String, ByVal Nouveau As String)
   Dim TA() As String, TN() As String, TLkSrc(), N As Long, Lien As String, _
      TL() As String, PL As Long, P As Long, ÀChanger As Boolean
   TA = Split(Replace(Ancien, "...", "…"), "\")
   TN = Split(Replace(Nouveau, "...", "…"), "\")
   If UBound(TA) <> UBound(TN) Then MsgBox UBound(TN) + 1 & _
      " éléments spécifiés en remplacement de " & UBound(TA) + 1, _
      vbCritical, "ChangerLiens": Exit Sub
   For P = 0 To UBound(TA)
      If TN(P) = "…" Xor TA(P) = "…" Then MsgBox "Code ""…"" incohérent position " & P + 1 _
         & vbLf & "Nouveau = """ & TN(P) & """ pour """ & TA(P) & """.", _
         vbCritical, "ChangerLiens": Exit Sub
      Next P
   TLkSrc = ThisWorkbook.LinkSources
   For N = 1 To UBound(TLkSrc)
      Lien = TLkSrc(N): TL = Split(Lien, "\"): PL = -1
      ÀChanger = True
      For P = 0 To UBound(TA)
         If TA(P) = "…" Then
            PL = P + UBound(TL) - UBound(TA)
         Else: PL = PL + 1
            If TA(P) <> "*" Then If TL(PL) <> TA(P) Then ÀChanger = False: Exit For
            If TN(P) <> "*" Then TL(PL) = TN(P)
            End If: Next P
      If ÀChanger Then ChangerLien Lien, Join(TL, "\")
      Next N
   End Sub
Sub ChangerLien(ByVal Ancien As String, ByVal Nouveau As String)
   If Ancien = Nouveau Then Exit Sub
   If MsgBox("Voulez vous changer le lien """ & Ancien & """ en """ & Nouveau & """ ?", _
      vbYesNo + vbExclamation, Me.Name) = vbNo Then Exit Sub
   On Error Resume Next
   ThisWorkbook.ChangeLink Ancien, Nouveau, xlLinkTypeExcelLinks
   If Err Then MsgBox "Err " & Err & " en tentant de changer le lien." _
      & vbLf & Err.Description, vbCritical, Me.Name
   End Sub
La première peut changer la racine ou la fin de certains liens.
Spécifiez pour Ancien et Nouveau des textes comportant des "\".
Entre deux "\" mettez des sous dossiers ou "*" ou "…"
"*" pour reconnaitre n'importe lequel et/ou ne pas le changer,
"…" pour allez à la fin des chemins.
Faites des essais.
 
Dernière édition:
Vote positif 0 Vote négatif
Dranreb

Dranreb

XLDnaute Barbatruc
Remarque: Il serait aussi possible, et même plus simple, de changer en faveur d'une nouvelle référence de fichier complète une liaison existante quelle qu'elle soit, quitte à boucler sur un MsgBox jusqu'à ce qu'on réponde Oui ou Annuler. Préfèreriez vous cette solution ?
Ça donnerait à peu près ça :
VB: 
Option Explicit

Sub Test()
RectifierLiaison Nouvelle:="C:\Toto\Bidon.xlsx"
End Sub

Sub RectifierLiaison(ByVal Nouvelle As String)
   Dim TLkSrc(), N As Long
   On Error Resume Next
   TLkSrc = ThisWorkbook.LinkSources(xlLinkTypeExcelLinks)
   If Err Then MsgBox "Aucune liaison trouvée.", vbCritical, "RectifierLiaison": Exit Sub
   Do: N = N Mod UBound(TLkSrc) + 1
      Select Case MsgBox("— Liaison désirée :" & vbLf & Nouvelle _
         & vbLf & vbLf & "— Liaison existante " & N & " :" & vbLf & TLkSrc(N) _
         & vbLf & vbLf & "Est-ce cette liaison que vous voulez changer ?", _
         vbYesNoCancel, "RectifierLiaison")
         Case vbYes: Exit Do: Case vbCancel: Exit Sub: End Select: Loop
   Err.Clear
   ThisWorkbook.ChangeLink TLkSrc(N), Nouvelle, xlLinkTypeExcelLinks
   If Err Then MsgBox "Err " & Err & " en tentant de changer le lien." _
         & vbLf & Err.Description, vbCritical, "RectifierLiaison"
   End Sub
 
Dernière édition:
Vote positif 0 Vote négatif
Dranreb

Dranreb

XLDnaute Barbatruc
La voici même un peu étoffée pour qu'elle ne propose de changer qu'une liaison existante différente de celle souhaitée.
VB: 
Option Explicit

Sub Test()
RectifierLiaison Nouvelle:="C:\Toto\Bidon.xlsx"
End Sub

Sub RectifierLiaison(ByVal Nouvelle As String)
   Dim TLkSrc(), MsgDéb As String, Ancienne, N As Long
   MsgDéb = "— Liaison désirée :" & vbLf & Nouvelle & vbLf & vbLf
   On Error Resume Next
   TLkSrc = ThisWorkbook.LinkSources(xlLinkTypeExcelLinks)
   If Err Then MsgBox MsgDéb & "Aucune liaison existante trouvée.", _
      vbCritical, "RectifierLiaison": Exit Sub
   For Each Ancienne In TLkSrc
      If Ancienne <> Nouvelle Then N = N + 1: TLkSrc(N) = Ancienne
      Next Ancienne
   If N < UBound(TLkSrc) Then
      Select Case N
         Case 0: MsgDéb = MsgDéb & "Aucune liaison différente n'existe."
         Case 1: MsgDéb = MsgDéb & "— Seule liaison différente :" & vbLf
         Case Else: MsgDéb = MsgDéb & "— Liaison différente ": End Select
      ReDim Preserve TLkSrc(1 To N)
   ElseIf N <= 1 Then
      MsgDéb = MsgDéb & "— Seule liaison existante :" & vbLf
   Else
      MsgDéb = MsgDéb & "— Liaison existante ": End If
   If N = 0 Then MsgBox MsgDéb, vbCritical, "RectifierLiaison": Exit Sub
   If UBound(TLkSrc) > 1 Then
      Do: N = N Mod UBound(TLkSrc) + 1: Ancienne = TLkSrc(N)
         Select Case MsgBox(MsgDéb & N & " :" & vbLf & Ancienne & vbLf & vbLf & _
            "Est-ce celle ci que vous voulez changer ?", _
            vbYesNoCancel + vbQuestion, "RectifierLiaison")
            Case vbYes: Exit Do: Case vbCancel: Exit Sub: End Select: Loop
   Else
      Ancienne = TLkSrc(1)
      If MsgBox(MsgDéb & Ancienne & vbLf & vbLf & "Êtes-vous sûr de vouloir la changer ?", _
         vbYesNoCancel + vbQuestion, "RectifierLiaison") <> vbYes Then Exit Sub
      End If
   Err.Clear
   ThisWorkbook.ChangeLink Ancienne, Nouvelle, xlLinkTypeExcelLinks
   If Err Then MsgBox "Err " & Err & " en tentant de changer la liaison." _
         & vbLf & Err.Description, vbCritical, "RectifierLiaison"
   End Sub
 
Dernière édition:
Vote positif 0 Vote négatif
J

jamespatagueul

XLDnaute Occasionnel
Dranreb à dit:
Voici deux procédures susceptible de changer d'autres liens :
VB: 
Sub ChangerLiens(ByVal Ancien As String, ByVal Nouveau As String)
   Dim TA() As String, TN() As String, TLkSrc(), N As Long, Lien As String, _
      TL() As String, PL As Long, P As Long, ÀChanger As Boolean
   TA = Split(Replace(Ancien, "...", "…"), "\")
   TN = Split(Replace(Nouveau, "...", "…"), "\")
   If UBound(TA) <> UBound(TN) Then MsgBox UBound(TN) + 1 & _
      " éléments spécifiés en remplacement de " & UBound(TA) + 1, _
      vbCritical, "ChangerLiens": Exit Sub
   For P = 0 To UBound(TA)
      If TN(P) = "…" Xor TA(P) = "…" Then MsgBox "Code ""…"" incohérent position " & P + 1 _
         & vbLf & "Nouveau = """ & TN(P) & """ pour """ & TA(P) & """.", _
         vbCritical, "ChangerLiens": Exit Sub
      Next P
   TLkSrc = ThisWorkbook.LinkSources
   For N = 1 To UBound(TLkSrc)
      Lien = TLkSrc(N): TL = Split(Lien, "\"): PL = -1
      ÀChanger = True
      For P = 0 To UBound(TA)
         If TA(P) = "…" Then
            PL = P + UBound(TL) - UBound(TA)
         Else: PL = PL + 1
            If TA(P) <> "*" Then If TL(PL) <> TA(P) Then ÀChanger = False: Exit For
            If TN(P) <> "*" Then TL(PL) = TN(P)
            End If: Next P
      If ÀChanger Then ChangerLien Lien, Join(TL, "\")
      Next N
   End Sub
Sub ChangerLien(ByVal Ancien As String, ByVal Nouveau As String)
   If Ancien = Nouveau Then Exit Sub
   If MsgBox("Voulez vous changer le lien """ & Ancien & """ en """ & Nouveau & """ ?", _
      vbYesNo + vbExclamation, Me.Name) = vbNo Then Exit Sub
   On Error Resume Next
   ThisWorkbook.ChangeLink Ancien, Nouveau, xlLinkTypeExcelLinks
   If Err Then MsgBox "Err " & Err & " en tentant de changer le lien." _
      & vbLf & Err.Description, vbCritical, Me.Name
   End Sub
La première peut changer la racine ou la fin de certains liens.
Spécifiez pour Ancien et Nouveau des textes comportant des "\".
Entre deux "\" mettez des sous dossiers ou "*" ou "…"
"*" pour reconnaitre n'importe lequel et/ou ne pas le changer,
"…" pour allez à la fin des chemins.
Faites des essais.
Cliquez pour agrandir...



Bonjour Bernard,

merci. Ou dois je coller cette macro; module ou thisworkbook.
J'ai tester les 2 façons, je ne trouve pas comment lancer la macro.
 
Vote positif 0 Vote négatif
Dranreb

Dranreb

XLDnaute Barbatruc
Bonjour.
Elle est faite pour un module standard, alors elle peut être invoquée de n'importe où où on peut en avoir besoin. Mais si elle n'est invoquée que depuis une procédure évènement d'un module objet, elle peut aussi être mise dans celui ci, et plutôt Private dans ce cas.
Syntaxe de l'appel: ChangerLiens ModèleDeLiaisonExistante, NouveauModèleDésiré
Un peu comme dans la Sub Test de ma dernière proposition, qui appelle RectifierLiaison, laquelle n'a besoin que d'un seul paramètre: la nouvelle liaison exacte désirée, puisque c'est elle qui propose tour à tour toutes les liaisons existantes jusqu'à ce qu'on en accepte une comme étant celle à modifier, ou qu'on annule.
 
Dernière édition:
Vote positif 0 Vote négatif
Dranreb

Dranreb

XLDnaute Barbatruc
Bonjour.
Autre exemple d'utilisation :
VB: 
Sub LierÀUnAutreClasseur()
Dim ChNomF
On Error Resume Next: ChDrive ThisWorkbook.Path: ChDir ThisWorkbook.Path: On Error GoTo 0
ChNomF = Application.GetOpenFilename("Fichier Excel,*.xlsx;*.xlsm;*.xls", Title:="Désigner le nouveau classeur lié")
If VarType(ChNomF) <> vbString Then Exit Sub
RectifierLiaison Nouvelle:=ChNomF
End Sub
Remarque: Cette macro ne requiert aucun paramètre, c'en est donc une qu'il est possible de lancer.

Mais bon… À force, on va finir par ne plus faire mieux que la commande Modifier les liaisons :
upload_2018-6-12_12-55-28.png
 
Dernière édition:
Vote positif 0 Vote négatif

Discussions similaires

E
  • Résolu(e)
Microsoft 365 Somme de NB.SI
Réponses
5
Affichages
146
eric72
E
P
  • Question
Microsoft 365 VBA - Enregistrer un fichier en pdf dans un dossier dont on ne connait que les 4 premiers caractères
Réponses
2
Affichages
225
phil75016
P
W
  • Question
Microsoft 365 VBA: Combiner/Compiler des fichiers PDF dans un chemin existant dans ordre
Réponses
2
Affichages
212
kiki29
kiki29
N
  • Question
Microsoft 365 Mise à jour de données d'un fichier Excel à un autre, sous Sharepoint
Réponses
0
Affichages
119
Newbeee
N
O
  • Question
XL 2019 Comment mettre à jour une réponse d'une liste déroulante
Réponses
7
Affichages
411
olivise
O
BenHarber
  • Question
Microsoft 365 Interroger un fichier source d'un autre format qu'Excel ?
Réponses
3
Affichages
152
BenHarber
BenHarber
M
  • Question
XL 2013 limiter les données du fichier RECAP au dossier actif
Réponses
1
Affichages
363
sylvanu
sylvanu
T
  • Résolu(e)
XL 2010 VBA - Bouton extraction structure dossier sélectionné
Réponses
5
Affichages
628
Titi456
T
J
  • Question
Microsoft 365 Problème lien hypertexte
Réponses
5
Affichages
210
Phil69970
Phil69970
A
  • Résolu(e)
XL 2021 VBA comment utiliser "contient" ?
2
Réponses
20
Affichages
418
Dranreb
Dranreb

Membres actuellement en ligne

Aucun membre en ligne actuellement.
0 membres et 34 invités.

Partager cette page

Tutos vidéos

Power Query : Ajouter des requêtes (Excel et Power BI)
Créez votre première fonction LAMBDA dans Excel en 3 étapes!
LAMBDA, l’arme secrète de Microsoft pour Excel !
Office Insider - Découvrez les nouveautés Excel avant tout le monde

Statistiques des forums

Discussions
312 206
Messages
2 086 219
Membres
103 158
dernier inscrit
laufin