Ceci est une page optimisée pour les mobiles. Cliquez sur ce texte pour afficher la vraie page.

XL 2019 Code VBA, chercher un fichier et mettre hyperlink dans cellule correspondante

laktats

XLDnaute Nouveau
Bonjour,
Je cherche à écrire un code vba, qui me permettra de chercher un fichier depuis son nom sous forme de numéro inscris dans une cellule, puis mettre le résultat de la recherche sous forme de chemin du fichier trouvé dans une cellule.
Je dispose d'un tableau dans lequel j'ai une colonne "CHILD OP", ce sont des N°OF. Aussi les cellules de la colonne "CHILD PRODUCT" sont des N°Série.
L'objectif est d'écrire une boucle qui va parcourir toutes les colonnes de mon tableau, ligne par ligne pour chercher si on a un fichier avec comme nom un N°OF - N°Série existe dans notre répertoire définit fixe. Si le fichier existe et que dans son Nom on a "MT", mettre hyperlink de ce fichier dans cellule colonne "MT" de la ligne associé, pareil pour "PT"/ "UT"/"VT"...
J'ai commencé par établir un code en s'aidant d'internet, mais je penses avoir plusieurs erreurs que je n'arrive pas à corriger ou à m'en apercevoir.
Si qq peut m'aider svp je bloque sur ca ^^ MERCI !
Voici mon code !
VB:
Sub Aspirateur()

    Dim Fso As Object, Rep As String
    Dim f1 As Object, f2 As Object, Present As Integer
    i = 2
    NomIncomplet = Cells(i, 4) & "-" & Cells(i, 5) & "-"
    
    '& Cells(1, 7) & "-" & Cells(1, 8) & "-" & Cells(1, 9) & "-" & Cells(1, 10)
    Present = 0
    Rep = "C:\Users\" & Environ("Username") & "\Alstom\DLC - Documents\MS\CND" & "\"     'Définit le répertoire contenant les fichiers, c'est à dire la directory courante
    
  
    Set Fso = CreateObject("Scripting.FileSystemObject")
        For Each f1 In Fso.GetFolder(Rep).SubFolders    ' Dans le dossier
            ' et chaque sous dossiers
            For Each f2 In f1.Files
                ' Si le nom du fichier contient le morceau de nom cherché alors
                If f2.Name Like "*" & NomIncomplet & "*" = True Then
                    If f2.Name Like "*" & Cells(1, 7) & "*" = True Then
                         Set MonApp = CreateObject("Shell.Application")
                         Chemin = Rep & f2.Name
                         Cells(i, 7) = f2.Name
                         MonApp.Open (Chemin)
                         ActiveSheet.Hyperlinks.Add Anchor:=Cells(i, 7), _
                         Address:=FileItem.ParentFolder & "\" & f2.Name
                         Set MonApplication = Nothing
                         Present = 1
                        
                    End If
                    
                    If f2.Name Like "*" & Cells(1, 8) & "*" = True Then
                         Set MonApp = CreateObject("Shell.Application")
                         Chemin = Rep & f2.Name
                         Cells(i, 8) = f2.Name
                         MonApp.Open (Chemin)
                         ActiveSheet.Hyperlinks.Add Anchor:=Cells(i, 8), _
                         Address:=FileItem.ParentFolder & "\" & f2.Name
                         Set MonApplication = Nothing
                         Present = 1
                    End If
                    If f2.Name Like "*" & NomIncomplet & "*" & Cells(1, 9) & "*" = True Then
                         Set MonApp = CreateObject("Shell.Application")
                         Chemin = Rep & f2.Name
                         Cells(i, 9) = f2.Name
                         MonApp.Open (Chemin)
                         ActiveSheet.Hyperlinks.Add Anchor:=Cells(i, 9), _
                         Address:=FileItem.ParentFolder & "\" & f2.Name
                         Set MonApplication = Nothing
                         Present = 1
                    End If
                    If f2.Name Like "*" & NomIncomplet & "*" & Cells(1, 10) & "*" = True Then
                         Set MonApp = CreateObject("Shell.Application")
                         Chemin = Rep & f2.Name
                         Cells(i, 10) = f2.Name
                         MonApp.Open (Chemin)
                         ActiveSheet.Hyperlinks.Add Anchor:=Cells(i, 10), _
                         Address:=FileItem.ParentFolder & "\" & f2.Name
                         Set MonApplication = Nothing
                         Present = 1
                    End If
                    Set MonApp = CreateObject("Shell.Application")
                    Chemin = Rep & f2.Name
                    MonApp.Open (Chemin)
                    Set MonApplication = Nothing
                    Present = 1
                End If
            Next f2
        Next f1
 i = i + 1
 
 
 

End Sub
 

laktats

XLDnaute Nouveau
Bonjour,
j'ai essayé de corriger, j'ai une erreur qui me dis for sans next je comprends pas
VB:
Sub Aspirateur()

    Dim Fso As Object, Rep As String
    Dim f1 As Object, f2 As Object
  
    i = 2
    NomIncomplet = Cells(i, 4) & "-" & Cells(i, 5) & "-"
    Present = 0
    Rep = "C:\Users\" & Environ("Username") & "\Alstom\DLC - Documents\MS\CND" & "\"
    
    Set Fso = CreateObject("Scripting.FileSystemObject")
    For Each f1 In Fso.GetFolder(Rep).SubFolders
            j = 3
            Do While Cells(i, j) <> ""
            i = i + 1
        For Each f2 In f1.Files
                ' Si le nom du fichier contient le morceau de nom cherché alors
                If f2.Name Like "*" & NomIncomplet & "*" = True Then
            
                    Set MonApp = CreateObject("Shell.Application")
                    Chemin = Rep & f2.Name
                    
                    If f2.Name Like "*" & Cells(1, 7) & "*" = True Then
                    
                         Cells(i, 7) = f2.Name
                         ActiveSheet.Hyperlinks.Add Anchor:=Cells(i, 7), _
                         Address:=FileItem.ParentFolder & "\" & f2.Name
                    Else
                        Cells(i, 7) = "Fichier Inexistant"
                    End If
                    
                    If f2.Name Like "*" & Cells(1, 8) & "*" = True Then
                         Cells(i, 8) = f2.Name
                         ActiveSheet.Hyperlinks.Add Anchor:=Cells(i, 8), _
                         Address:=FileItem.ParentFolder & "\" & f2.Name
                    Else
                        Cells(i, 8) = "Fichier Inexistant"
                    End If
                    
                    If f2.Name Like "*" & Cells(1, 9) & "*" = True Then
                         Cells(i, 9) = f2.Name
                         ActiveSheet.Hyperlinks.Add Anchor:=Cells(i, 9), _
                         Address:=FileItem.ParentFolder & "\" & f2.Name
                     Else
                        Cells(i, 9) = "Fichier Inexistant"
                    End If
                    
                    If f2.Name Like "*" & Cells(1, 10) & "*" = True Then
                         Cells(i, 10) = f2.Name
                         ActiveSheet.Hyperlinks.Add Anchor:=Cells(i, 10), _
                         Address:=FileItem.ParentFolder & "\" & f2.Name
                     Else
                        Cells(i, 10) = "Fichier Inexistant"
                    End If
 
                    MonApp.Open (Chemin)
                    Set MonApplication = Nothing
                    Present = 1
                End If
         Next f2
    Next f1
            
                
      i = i + 1
  Loop

End Sub
 

sylvanu

XLDnaute Barbatruc
Supporter XLD
Bonjour,
Votre code est mal indenté donc on le vois pas. Sinon ça donnerait :
VB:
Sub Aspirateur()
For Each f1 In Fso.GetFolder(Rep).SubFolders
    '...
    Do While Cells(i, j) <> ""
        i = i + 1
        '...
        For Each f2 In f1.Files
            '...
        Next f2
    Next f1
      i = i + 1
Loop
End Sub
On voit que Loop n'est pas au même niveau que Do et Next f1 pas au même niveau que For f1.
Donc pour corriger :
Code:
Sub Aspirateur()
For Each f1 In Fso.GetFolder(Rep).SubFolders
    '...
    Do While Cells(i, j) <> ""
        i = i + 1
        '...
        For Each f2 In f1.Files
            '...
        Next f2
    Loop
Next f1
End Sub
 

laktats

XLDnaute Nouveau
Bonjour,
merci pour la correction ! j'ai modifié le code mais cette fois-ci rien ne se passe !
Le code cherche dans un repertoire des fichiers avec pour nom un n°OF. Dans mon fichier un tableau j'ai en colonne 3 Child OP les numéros OF de plusieurs fichiers. Le but est de boucler sur les lignes de mon tableau et chercher tous les fichiers qui ont pour noms mes N°OF et mettre lien hypertexte de ce fichier dans une cellule. Cette cellule sera MT, si dans le nom on a MT. si dans nom on a UT, alors on met lien hypertexte de mon fichier dans cellule colonne UT.
Voici le format du fichier recherché : 12345678-MT-195365-2-Longeron Gauche
8 premier digits pour le N°OF et l'information MT/PT/UT/VT juste apres pour savoir ou mettre dans les cellules !
VB:
Sub Aspi2()


    Dim Fso As Object, Rep As String
    Dim f1 As Object, f2 As Object
 
    i = 2
    NomIncomplet = Cells(i, 4) & "-" & Cells(i, 5) & "-"
    Present = 0
    Rep = "C:\Users\" & Environ("Username") & "\Alstom\DLC - Documents\MS\CND" & "\"
    
    Set Fso = CreateObject("Scripting.FileSystemObject")
    For Each f1 In Fso.GetFolder(Rep).SubFolders
            j = 3
            Do While Cells(i, j) <> ""
            i = i + 1
        For Each f2 In f1.Files
                ' Si le nom du fichier contient le morceau de nom cherché alors
                    If f2.Name Like "*" & NomIncomplet & "*" & Cells(1, 7) & "*" = True Then
                         Set MonApp = CreateObject("Shell.Application")
                         Chemin = Rep & f2.Name
                         Cells(i, 7) = f2.Name
                         ActiveSheet.Hyperlinks.Add Anchor:=Cells(i, 7), _
                         Address:=FileItem.ParentFolder & "\" & f2.Name
                         MonApp.Open (Chemin)
                    Else
                        Cells(i, 7) = "Fichier Inexistant"
                    End If
                    
                    If f2.Name Like "*" & NomIncomplet & "*" & Cells(1, 8) & "*" = True Then
                         Set MonApp = CreateObject("Shell.Application")
                         Chemin = Rep & f2.Name
                         Cells(i, 8) = f2.Name
                         ActiveSheet.Hyperlinks.Add Anchor:=Cells(i, 8), _
                         Address:=FileItem.ParentFolder & "\" & f2.Name
                         MonApp.Open (Chemin)
                    Else
                        Cells(i, 8) = "Fichier Inexistant"
                    End If
                    
                    If f2.Name Like "*" & NomIncomplet & "*" & Cells(1, 9) & "*" = True Then
                         Set MonApp = CreateObject("Shell.Application")
                         Chemin = Rep & f2.Name
                         Cells(i, 9) = f2.Name
                         ActiveSheet.Hyperlinks.Add Anchor:=Cells(i, 9), _
                         Address:=FileItem.ParentFolder & "\" & f2.Name
                         MonApp.Open (Chemin)
                     Else
                        Cells(i, 9) = "Fichier Inexistant"
                    End If
                    
                    If f2.Name Like "*" & NomIncomplet & "*" & Cells(1, 10) & "*" = True Then
                         Set MonApp = CreateObject("Shell.Application")
                         Chemin = Rep & f2.Name
                         Cells(i, 10) = f2.Name
                         ActiveSheet.Hyperlinks.Add Anchor:=Cells(i, 10), _
                         Address:=FileItem.ParentFolder & "\" & f2.Name
                         MonApp.Open (Chemin)
                     Else
                        Cells(i, 10) = "Fichier Inexistant"
                    End If
 
                    'MonApp.Open (Chemin)
                    Set MonApplication = Nothing
                    Present = 1
                
          Next f2
       Loop
     Next f1

End Sub
c'est ce que j'essaye de réaliser dans ce fichier la, je suis novice en vba et je suis en plein apprentissage si vous pouviez m'éclairer ! ^^
 

Discussions similaires

Réponses
0
Affichages
352
Réponses
6
Affichages
613
Les cookies sont requis pour utiliser ce site. Vous devez les accepter pour continuer à utiliser le site. En savoir plus…