Twitter iPhone pliant OnePlus 11 PS5 Disney+ Orange Livebox Windows 11

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

1 réponse
Avatar
moumoute31
Bonjour,

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

Ce que je souhaite
- Enregistrer les liens hypertext =E0 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 =3D 1

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

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

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

Dans cette partie, je bloque

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

End Sub

Sub arborescence()
Set fs =3D CreateObject("Scripting.FileSystemObject")
racine =3D ThisWorkbook.Sheets("Classeurs").Cells(2, 1).Value
Set adress =3D fs.getfolder(racine)
lit_dossier adress, 1
End Sub

1 réponse

Avatar
PMO
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