Macro pour lien hypertexte liste de documents Le sujet est résolu

Y compris Power BI, Power Query et toute autre question en lien avec Excel
S
Snail
Jeune membre
Jeune membre
Messages : 24
Inscrit le : 26 octobre 2013
Version d'Excel : 2010 et 2013 FR

Message par Snail » 12 mai 2016, 15:19

Bonjour tout le monde,

Je cherche à faire l'action suivante avec une macro sans y parvenir.

J'ai une feuille Excel avec une colonne contenant des références de pièces.
J'ai un dossier contenant plein de sous-dossiers avec différents types de fichiers à l'intérieur de chaque sous-dossier. Les sous-dossiers comportent dans leur noms au moins le numéro des références spécifié dans la feuille Excel (il se peut qu'il y ai d'autres caractères dans le nom des dossiers).
Dans chacun des sous dossiers se trouver des fichiers .pdf (plans et nomenclatures de pièces) et des .tif.

J'aimerais que lorsque que je clique dans mon fichier Excel sur une référence (cellule ou lien hypertexte) cela créé une liste dans une nouvelle Feuille Excel de l'ensemble des fichiers (.pdf et .tif) se trouvant dans le sous-dossier qui contient le nom de cette référence, en effectuant une recherche de ce sous-dossier dans mon dossier principal. J'aimerais que cette liste de fichier pointe avec des liens hypertextes vers les fichiers (.pdf et .tif) pour pouvoir les ouvrir rapidement.
Si possible j'aimerais aussi que la feuille qui contient cette liste s'auto supprime dès que l'on change de worksheet/feuille, afin qu'il n'y ai pas une infinité de feuille de créé à chaque fois que l'on clique sur une réf.

Je ne sais pas si c'est 100% clair ?

J'ai trouvé un code qui fait la moitier du boulot, mais je ne sais comment coder le reste... Le code ouvre une fenetre pour selectionner le répertoire. Je préférerais que le répertoire du dossier principal soit déjà dans le code.
http://www.vbaexpress.com/kb/getarticle.php?kb_id=232
Option Compare Text 
Option Explicit 
 
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 
 
Sub HyperlinkFileList() 
     'Macro purpose:  To create a hyperlinked list of all files in a user
     'specified directory, including file size and date last modified
     'NOTE:  The 'TextToDisplay' property (of the Hyperlink object) was added
     'in Excel 2000.  This code tests the Excel version and does not use the
     'Texttodisplay property if using XL 97.
     
    Dim fso As Object, _ 
    ShellApp As Object, _ 
    File As Object, _ 
    SubFolder As Object, _ 
    Directory As String, _ 
    Problem As Boolean, _ 
    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
        Directory = ShellApp.self.path 
        Set SubFolder = fso.GetFolder(Directory).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
    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 
     
End Sub 
Est-ce que quelqu'un pourrait m'aider.

Merci pour votre attention
Modifié en dernier par Snail le 18 mai 2016, 10:53, modifié 1 fois.
S
Snail
Jeune membre
Jeune membre
Messages : 24
Inscrit le : 26 octobre 2013
Version d'Excel : 2010 et 2013 FR

Message par Snail » 18 mai 2016, 10:53

Bonjour à tous,

Personne pour me donner un coup de main ? Je galère vraiment pour avoir une macro qui fonctionne...

Merci pour votre attention
S
Snail
Jeune membre
Jeune membre
Messages : 24
Inscrit le : 26 octobre 2013
Version d'Excel : 2010 et 2013 FR

Message par Snail » 28 juin 2016, 11:04

Ci-joint ce que j'utilise
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 Function
Répondre Sujet précédentSujet suivant
  • Sujets similaires
    Réponses
    Vues
    Dernier message