Hyperlink d'autre classeur enregistrer dans le classeur d'origine
1 réponse
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
Cette action est irreversible, confirmez la suppression du commentaire ?
Signaler le commentaire
Veuillez sélectionner un problème
Nudité
Violence
Harcèlement
Fraude
Vente illégale
Discours haineux
Terrorisme
Autre
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
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
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