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 répertoire
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
Vidéos High-Tech et Jeu Vidéo
Téléchargements
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