Liens hypertextes automatique / Référence = même cellule
Bonjour à tous,
Je cherche à effectuer une action que je pense assez atypique et donc pour laquelle je n'ai rien trouvé en effectuant mes recherches sur le net.
J'ai une liste de numéro de plans d'outils assez longue.
Pour cette liste j'aimerais créer un lien hypertexte vers les plans d'outils correspondant qui sont stockés dans des sous-dossiers à leur noms dans un dossier principale PLANS ET NOMENCLATURES.
Dans ce genre :
PLANS ET NOMENCLATURES
---> M-430-06_002
fichier 1
fichier 2 ....
---> M-430-06_004
fichier 1
fichier 2 ....
---> M-430-06_032
fichier 1
fichier 2 ....
Pour une liste moins longue, j'ai réussi à trouver et faire marcher un code VBA (ci-joint) qui liste dans une nouvelle feuille l'ensemble des fichiers qui se trouvent dans le sous-dossier au nom de la cellule (dans le dossier principale) et créé des liens hypertextes vers chacun de ces fichiers.
C'est super pratique !
Par contre il faut absolument que la cellule avec les numéros de plans d'outils contienne un lien hypertexte, qui rappelle cette même cellule. Je sais comment créer cela à la main et donc faire fonctionner le code, mais pour une liste de 10000 plans... je manque de patience.
Donc est-ce quelqu'un serait comment faire pour créer un lien hypertexte qui fasse référence à la même cellule que celle sur laquelle se trouve le lien hypertexte ?
Il faudrait quelque chose qui effectue l'action suivante en automatique :
Clique droit / Lien hypertexte / Emplacement dans ce document
Puis renseigne la valeur de la cellule active dans "Tapez la référence de la cellule"
OK
J'ai essayé des trucs sans y parvenir.
Option Compare Text
Option Explicit
Private Sub Worksheet_FollowHyperlink(ByVal Target As Hyperlink)
If InRange(ActiveCell, Range("K11646:K17457")) Then
Dim FSO As Object, _
ShellApp As Object, _
File As Object, _
SubFolder As Object, _
Directory As String, _
SubDir As String, _
Problem As Boolean, _
ws As Worksheet, _
ExcelVer As Integer
'Turn off screen flashing
Application.ScreenUpdating = False
'Create objects to get a listing of all files in the directory
Set FSO = CreateObject("Scripting.FileSystemObject")
'Prompt user to select a directory
Do
Problem = False
'Set ShellApp = CreateObject("Shell.Application"). _
'Browseforfolder(0, "Please choose a folder", 0, "c:\\")
On Error Resume Next
'Evaluate if directory is valid
'#################################################################'
'####REMPLACER LE REPERTOIRE OU SE TROUVE LES PLANS SI BESOIN#####'
'#################################################################'
Directory = "M:\......\PLANS ET NOMENCLATURES"
'Directory = ShellApp.self.Path
SubDir = Recurse(Directory)
Set SubFolder = FSO.GetFolder(SubDir).Files
If Err.Number <> 0 Then
If MsgBox("You did not choose a valid directory!" & vbCrLf & _
"Would you like to try again?", vbYesNoCancel, _
"Directory Required") <> vbYes Then Exit Sub
Problem = True
End If
On Error GoTo 0
Loop Until Problem = False
'Set up the headers on the worksheet
Set ws = ThisWorkbook.Sheets.Add(Before:= _
ThisWorkbook.ActiveSheet)
ws.Name = "Liste Outils Coupants"
With ActiveSheet
With .Range("A1")
.Value = "Listing of all files in:"
.ColumnWidth = 40
'If Excel 2000 or greater, add hyperlink with file name
'displayed. If earlier, add hyperlink with full path displayed
If Val(Application.Version) > 8 Then 'Using XL2000+
.Parent.Hyperlinks.Add _
Anchor:=.Offset(0, 1), _
Address:=Directory, _
TextToDisplay:=Directory
Else 'Using XL97
.Parent.Hyperlinks.Add _
Anchor:=.Offset(0, 1), _
Address:=Directory
End If
End With
With .Range("A2")
.Value = "File Name"
.Interior.ColorIndex = 15
With .Offset(0, 1)
.ColumnWidth = 15
.Value = "Date Modified"
.Interior.ColorIndex = 15
.HorizontalAlignment = xlCenter
End With
With .Offset(0, 2)
.ColumnWidth = 15
.Value = "File Size (Kb)"
.Interior.ColorIndex = 15
.HorizontalAlignment = xlCenter
End With
End With
End With
'Adds each file, details and hyperlinks to the list
For Each File In SubFolder
If Not Excludes(Right(File.Path, 3)) = True Then
With ActiveSheet
'If Excel 2000 or greater, add hyperlink with file name
'displayed. If earlier, add hyperlink with full path displayed
If Val(Application.Version) > 8 Then 'Using XL2000+
.Hyperlinks.Add _
Anchor:=ActiveSheet.Range("A65536").End(xlUp).Offset(1, 0), _
Address:=File.Path, _
TextToDisplay:=File.Name
Else 'Using XL97
.Hyperlinks.Add _
Anchor:=ActiveSheet.Range("A65536").End(xlUp).Offset(1, 0), _
Address:=File.Path
End If
'Add date last modified, and size in KB
With .Range("A65536").End(xlUp)
.Offset(0, 1) = File.datelastModified
With .Offset(0, 2)
.Value = WorksheetFunction.Round(File.Size / 1024, 1)
.NumberFormat = "#,##0.0"
End With
End With
End With
End If
Next
Else
' code to handle that the active cell is not within the right range
MsgBox "Active Cell NOT In Range!"
End If
'BUTTON
Dim btn As Button
Application.ScreenUpdating = False
ActiveSheet.Buttons.Delete
Dim t As Range
Set t = ActiveSheet.Cells(5, 5)
Set btn = ActiveSheet.Buttons.Add(t.Left, t.Top, t.Width, t.Height)
With btn
.OnAction = "ClickTheButton"
.Caption = "FERMER"
.Name = "FERMER"
End With
Application.ScreenUpdating = True
End Sub
Function Excludes(Ext As String) As Boolean
'Function purpose: To exclude listed file extensions from hyperlink listing
Dim X, NumPos As Long
'Enter/adjust file extensions to EXCLUDE from listing here:
X = Array("exe", "bat", "dll", "zip")
On Error Resume Next
NumPos = Application.WorksheetFunction.Match(Ext, X, 0)
If NumPos > 0 Then Excludes = True
On Error GoTo 0
End Function
Function InRange(Range1 As Range, Range2 As Range) As Boolean
' returns True if Range1 is within Range2
InRange = Not (Application.Intersect(Range1, Range2) Is Nothing)
End Function
Function Recurse(sPath As String) As String
Dim FSO2 As New FileSystemObject
Dim myFolder As Folder
Dim mySubFolder As Folder
Dim myFile As File
Dim pos As Integer
Set myFolder = FSO2.GetFolder(sPath)
For Each mySubFolder In myFolder.SubFolders
pos = InStr(mySubFolder.Name, ActiveCell.Value)
'For Each myFile In mySubFolder.Files
If pos <> 0 Then
Recurse = mySubFolder.Path
Exit For
End If
'Next
Recurse = Recurse(mySubFolder.Path)
Next
End FunctionSi vous connaissez un moyen pour m'aider je vous en serait reconnaissant.
Amicalement
Bonjour,
Tu devrais essayer de te relire et si tu te comprends dis le nous
Snail a écrit :Par contre il faut absolument que la cellule avec les numéros de plans d'outils contienne un lien hypertexte, qui rappelle cette même cellule. Je sais comment créer cela à la main et donc faire fonctionner le code, mais pour une liste de 10000 plans... je manque de patience.
Donc est-ce quelqu'un serait comment faire pour créer un lien hypertexte qui fasse référence à la même cellule que celle sur laquelle se trouve le lien hypertexte ?
???
Bonjour,
Donc est-ce quelqu'un serait comment faire pour créer un lien hypertexte qui fasse référence à la même cellule que celle sur laquelle se trouve le lien hypertexte ?
J'ai un peu de mal à comprendre, mais je vais reprendre un café et si vous pouviez mettre une maquette Excel de ce que vous avez et ce que vous voulez, cela serait surement plus aisé.
Bien à vous
Jp
Bon j'ai mis un screenshot en pièce jointe pour essayer d'aider à la compréhension.
Imaginons que je souhaite créer un lien hypertexte sur l'outil M-430-06_002 (la cellule selectionnée sur l'exemple) qui me rédirige sur cette même cellule.
En temps normal pour faire ça, je clique droit sur la cellule, "Insérer un lien hypertexte", "Emplacement dans ce document", puis je renseigne à la main le numéro de cellule correspondant (dans mon exemple c'est H4).
Je souhaiterais faire la même opération mais en Macro. C'est à dire la création d'un lien hypertext vers la cellule selectionnée.
Est-ce que c'est un peu plus clair ?
Bonsoir Snail
Heuuuu... juste comme ça, quel intérêt
En général quand on met un lien hypertexte c'est pour aller sur une autre feuille ou ouvrir un document
L'intérêt est de pouvoir lancer etfaire fonctionner la macro dont je vous ai fait un copier/coller dans mon premier poste, en cliquant sur ces liens hypertextes.
Re,
Snail a écrit :L'intérêt est de pouvoir lancer etfaire fonctionner la macro dont je vous ai fait un copier/coller dans mon premier poste, en cliquant sur ces liens hypertextes.
Ah ben oui, pourquoi faire simple, quand on veut faire compliqué
Bonne chance...
Bonjour,
Voyez-vous une autre parade pour déclencher la Macro ?
Personnellement, je trouve ça pratique d'avoir à cliquer sur le lien hypertexte...
Cordialement
Re,
Snail a écrit :Personnellement, je trouve ça pratique d'avoir à cliquer sur le lien hypertexte
Tout à fait d'accord
Il suffit que le lien pointe directement vers le fichier, ce que semble faire ton code !?
Si tu pouvais nous envoyer un bout de fichier avec ton code, ce serait franchement plus simple pour la compréhension
A+