Hyperlink d'autre classeur enregistrer dans le classeur d'origine

Le
moumoute31
Bonjour,

voici le but de ma macro,
1) J'ouvre tous les classeurs situ dans un rpertoire
2) J'enregistre tous les onglets dans la 2eme colonne de thisworkbook
3) la je bloque, je voudrai engistrer les liens hypertext de chaque
classeur dans le thisworkbook (mais a enregistre dans les classeurs
que j'ouvre)

Ce que je souhaite
- Enregistrer les liens hypertext cet endroit
"ThisWorkbook.Sheets("BDD_APPRO").Cells(ChgSheets, 1)"

Mon code est juste en dessous, merci d'avance pour l'aide

Dim racine As String
Sub lit_dossier(ByRef dossier, ByVal niveau)
Dim NonFeuille As String
Dim ChgSheets As Integer
ChgSheets = 1

For Each d In dossier.SubFolders
lit_dossier d, niveau + 1
Next

Do
ChgSheets = ChgSheets + 1
Loop Until ThisWorkbook.Sheets("BDD_APPRO").Cells(ChgSheets, 2).Value
= Empty

For Each f In dossier.Files
Workbooks.Open Filename:=f

Dans cette partie, je bloque

For CTR = Sheets.Count To 1 Step -1
nomfeuille = Sheets(CTR).Name
ThisWorkbook.Sheets("BDD_APPRO").Cells(ChgSheets, 2).Value =
nomfeuille
ThisWorkbook.Sheets("BDD_APPRO").Cells(ChgSheets,
1).Hyperlinks.Add anchor:=Selection, Address:="" & f.Path & "",
TextToDisplay:=nomfeuille
ActiveCell.Offset(1, 0).Select
ChgSheets = ChgSheets + 1
Next
Next

End Sub

Sub arborescence()
Set fs = CreateObject("Scripting.FileSystemObject")
racine = ThisWorkbook.Sheets("Classeurs").Cells(2, 1).Value
Set adress = fs.getfolder(racine)
lit_dossier adress, 1
End Sub
Vos réponses
Gagnez chaque mois un abonnement Premium avec GNT : Inscrivez-vous !
Trier par : date / pertinence
PMO
Le #5378241
Bonjour,

Ci-dessous un exemple de code qui devrait vous mettre sur la piste.

1) Fabriquez un classeur avec plusieurs feuilles et nommez le "zaza"
puis placez le dans C: (ou changez la constante LE_FICHIER)
2) Copiez le code dans un autre classeur et faites tourner la macro


'***********************
Option Explicit
Const LE_FICHIER As String = "c:zaza.xls"
Sub PMO()
Dim WB As Workbook
Dim S As Worksheet
Dim i&
Dim ligne&
Dim R As Range
Set WB = GetObject(LE_FICHIER)
For i& = 1 To WB.Sheets.Count
Set S = WB.Sheets(i&)
ligne& = ligne& + 1
Set R = ThisWorkbook.Sheets(1).Range("B" & ligne& & "")
R = S.Name
Set R = R.Offset(0, -1)
S.Hyperlinks.Add _
Anchor:=R, _
Address:=WB.FullName, _
SubAddress:=S.Name & "!A1", _
ScreenTip:=WB.FullName & " " & S.Name, _
TextToDisplay:="Lien vers " & WB.Name
Next i&
WB.Close SaveChanges:úlse
Set R = Nothing
Set S = Nothing
Set WB = Nothing
End Sub
'***********************

Il n'y a plus qu'à adapter avec une boucle pour parcourir
tous les fichiers trouvés par le FSO


Cordialement.

--
PMO
Patrick Morange
Publicité
Poster une réponse
Anonyme