XL 2016 Rompre les liens avec les requêtes et autres liens

ZZ59264

XLDnaute Junior
Bonjour à tous,

Suite au code fourni par Job75 que je salue au passage, pourriez vous regarder le code proposé car en l'utilisant les liens avec mes requêtes est toujours présent et il y a également un lien créer avec le fichier source :

VB:
Sub Creer_Fichiers_Classes()
Dim F As Worksheet, classe$, P As Range, i As Variant, s, chemin$, c As Range, w As Worksheet, o As Object, nom As Name, sup As Boolean
'---préparation---
Set F = Feuil1 'CodeName
classe = F.DrawingObjects(Application.Caller).Text 'les boutons doivent avoir des noms différents
Set P = F.ListObjects(1).Range 'tableau structuré
i = Application.Match(classe, P.Columns(3), 0) 'EQUIV
If IsError(i) Then MsgBox classe & " non trouvée !", 48: Exit Sub
Set P = P(i, 1).Resize(Application.CountIf(P.Columns(3), classe), P.Columns.Count)
If Application.CountIf(P.Columns(5), "OK") <> P.Rows.Count Then MsgBox "Il faut que tous les onglets de " & classe & " soient validés par OK...": Exit Sub
'---création des dossiers s'ils n'existent pas---
s = Split(P(1, 4), "\")
chemin = s(0) & "\" 'lecteur
For i = 1 To UBound(s)
    chemin = chemin & s(i) & "\"
    If Dir(chemin, vbDirectory) = "" Then MkDir chemin
Next i
'---création des fichiers---
Application.ScreenUpdating = False
Application.DisplayAlerts = False 'si un fichier a déjà été créé
For Each c In P.Columns(1).Cells
    Set w = ThisWorkbook.Sheets(CStr(c))
    w.Visible = xlSheetVisible 'si la feuille est masquée
    Application.EnableEvents = False 'désactive les évènements
    If c(1, 2) <> c(0, 2) Then 'compare avec le nom de fichier au-dessus
        w.Copy 'crée un nouveau document
    Else
        w.Copy After:=ActiveSheet 'ajoute la feuille copiée
    End If
    Application.EnableEvents = True 'réactive les évènements
    For Each o In ActiveSheet.PivotTables 'TCD
        With o.TableRange2
            s = .Value 'mémorise les valeurs
            .ClearContents 'efface le TCD
            .Value = s 'restitue les valeurs
        End With
    Next o
    For Each o In ActiveSheet.ListObjects 'tableaux structurés
        o.Unlist 'convertit en plage
    Next o
    Range(w.UsedRange.Address) = w.UsedRange.Value 'supprime les formules
    If c(1, 2) <> c(2, 2) Then 'compare avec le nom de fichier au-dessous
    
On Error Resume Next
 For Each nom In ActiveWorkbook.Names
      If PréfixeFeuille(nom.Name) <> PréfixeFeuille(Mid$(nom.RefersTo, 2)) Then nom.Delete
 Next nom
 On Error GoTo 0
    
    
        Sheets(1).Select '1ère feuille
        ActiveWorkbook.SaveAs chemin & c(1, 2), 51 'enregistre avec l'extension .xlsx
        ActiveWorkbook.Close False 'ferme le document
    End If
Next c
End Sub

Merci d'avance,

Cordialement,
 

ZZ59264

XLDnaute Junior
Bonsoir à tous,

Afin de faire avancer mon problème je vous le fichier en question,

lorsque je clique sur le bouton classe 1, les onglets A et WA sont importes sur un nouveau fichier mais le problème c'est que je souhaiterai supprimer les liens avec les requêtes et le lien avec le fichier d'origine,

Merci d'avance pour votre aide,

Cordialement,
 

Pièces jointes

  • TEST FORUM.xlsm
    121.2 KB · Affichages: 7

job75

XLDnaute Barbatruc
Bonjour ZZ59264,

Pour les requêtes je ne vois pas mais pour supprimer les liens hypertextes c'est facile :
VB:
    Range(w.UsedRange.Address) = w.UsedRange.Value 'supprime les formules
    Cells.Hyperlinks.Delete 'supprime les liens hypertextes
A+
 

chris

XLDnaute Barbatruc
Bonjour

Tu as une requête PowerQuery qui alimente le tableau de l'onglet BASE TCD REQUETE

Il suffit de la supprimer, le tableau subsistera sans lien avec quoi que ce soit.
Tu peux supprimer l'onglet ensuite si plus besoin
 

ZZ59264

XLDnaute Junior
Bonjour Chris,

Non l'onglet base tcd requete contient un tableau structué qui alimente la requête dont le résultat est présent par un tcd et par son affichage sur l’onglet WA,

La macro de création de fichier permet de déplacer les feuilles A & WA sur un nouveau ficher et c'est la que je ne veux plus de lien avec l'ancien fichier (requête,liens...) , tester si vous le pouvez le fichier ce sera plus parlant je pense,

Merci d'avance,

Cordialement,
 
Dernière édition:

ZZ59264

XLDnaute Junior
Bonjour Job 75, oui le lien hypertexte disparait mais il me met à l'ouverture du fichier créer :

1642171623084.png
 

ZZ59264

XLDnaute Junior
Bonsoir jOB75?

Effectivement j'ai tester et ça fonctionne, je vais donc voir sur mon fichier de travail, car il me met une liaison,

Merci,

Cordialement,
Bonsoir Job75,

Après une heure de recherche, je rejoins le fichier pour test, je sais pourquoi le lien se créer sur mon fichier original et je l'ai transposé sur le fichier test,

En fait la cellule G2 de l'onglet WA à pour référence une liste de données de la feuille en têtes, et ce serait donc ces cellules de mon fichier de travail qui sont à l'origine de mes liaisons,

Le passage de votre macro de départ pour la suppression des noms était écrit comme ceci :

VB:
        For Each nom In ActiveWorkbook.Names
            sup = True
            For Each F In ActiveWorkbook.Worksheets
                If nom.Name Like F.Name & "!*" Or nom.Name Like "'" & F.Name & "'!*" Then sup = False
            Next F
            If sup Then nom.Delete 'supprime le nom sauf s'il est défini dans une feuille du document créé
        Next nom

Quand mon fichier bloquait avec les message d'erreur VBA non spécifié, on m'a suggérer cette façon plus rapide d'éxécution :

Code:
On Error Resume Next
 For Each nom In ActiveWorkbook.Names
      If PréfixeFeuille(nom.Name) <> PréfixeFeuille(Mid$(nom.RefersTo, 2)) Then nom.Delete
 Next nom
 On Error GoTo 0

avec deux fonctions :
Code:
Private Function PréfixeFeuille(ByVal Z As String) As String

   PréfixeFeuille = Left$(Z, PosPExcla(Z))

   End Function


Private Function PosPExcla(ByVal Z As String) As Long

Rem. Le nom de feuille peut contenir "!", et même "'!", ou commencer par "!", pourquoi pas, mais on ne peut

'    se contenter de chercher tout simplement le dernier "!" car la suite de Z peut aussi contenir "#REF!" !

   If Left$(Z, 1) = "'" Then PosPExcla = InStr(Replace(Mid$(Z, 2), "''", "??"), "'!") + 2 Else PosPExcla = InStr(Z, "!")

   End Function

Est ce que cela aurait une incidence sur la suppression de la liaison ou pas du tout?,

Sinon auriez vous une idée pour supprimer le lien qui se créer a cause des listes de données?,

Merci d'avance pour tout car je vous demande beaucoup de choses,

Cordialement,
 

Pièces jointes

  • Copie de TEST FORUM-1.xlsm
    121.9 KB · Affichages: 3

Discussions similaires

Statistiques des forums

Discussions
294 444
Messages
1 938 537
Membres
188 913
dernier inscrit
thibounet