1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78
| Sub chercheFichiersFermes()
Dim X As Integer, nbFichiers As Integer, z As Integer
Dim Tableau() As String
Dim Direction As String
Dim MO, NMO, CheminMO As String
Application.ScreenUpdating = False 'masque les rafraîchissements d'écran
ActiveSheet.Hyperlinks.Delete
Direction = Dir("C:\Users\Jihed\Desktop\jihed\*.xls") 'adapter chemin repertoire et ajouter "\*.xls" pour dire tout les fichiers("C:\Users\Dream\Desktop\Nouveau dossier")
Dim val As String
ActiveSheet.Hyperlinks.Delete
'compter le nombre de fichier
Do While Len(Direction) > 0
nbFichiers = nbFichiers + 1
'reservation d'un tableau selon le nombre de fichier
ReDim Preserve Tableau(1 To nbFichiers)
Tableau(nbFichiers) = Direction
Direction = Dir()
Loop
z = 1
'remplissage de tableau selon les données copier
If nbFichiers > 0 Then
For X = 1 To (nbFichiers - 1)
If Tableau(X) <> ThisWorkbook.Name Then ' si le nom de chaque fichier de MO différent de nom de ce ficheir
z = z + 1 ' compteur pour les ligne de tableau
'copier les données dans les MO et coller dans le tableau
With ActiveSheet.Cells(z, 1) ' K7 est l'article coller dans A
.Formula = "='C:\Users\Jihed\Desktop\jihed\[" & Tableau(X) & "]Débit" & "'!" & "K7" 'adapter chemin repertoire
.Value = .Value
End With
With ActiveSheet.Cells(z, 2) ' O2 est le MO coller dans B
.Formula = "='C:\Users\Jihed\Desktop\jihed\[" & Tableau(X) & "]Débit" & "'!" & "O2" 'adapter chemin repertoire
.Value = .Value
NMO = .Value
'lien hyper MO
CheminMO = "C:\Users\Jihed\Desktop\jihed" ' chemin de dossier MO
MO = CheminMO & "\" & NMO & ".xls"
ActiveSheet.Hyperlinks.Add Anchor:=Cells(z, 2), Address:=MO, TextToDisplay:=Cells(z, 2).Value ' creation de lien entre la cellule Moule et son fichier
End With
With ActiveSheet.Cells(z, 3) ' D18 est la moule coller dans C
.Formula = "='C:\Users\Jihed\Desktop\jihed\[" & Tableau(X) & "]Moulage" & "'!" & "D18" 'adapter chemin repertoire
.Value = .Value
End With
With ActiveSheet.Cells(z, 4) ' E18 est le gabarit coller dans D
.Formula = "='C:\Users\Jihed\Desktop\jihed\[" & Tableau(X) & "]Détourage" & "'!" & "E18" 'adapter chemin repertoire
.Value = .Value
End With
End If
Next X
End If
'ouvrir les fichiers pour copier les données
Dim i As Long
Set Recherche = ClFileSearch.Nouvelle_Recherche
With Recherche
'Définit le répertoire de recherche
.FolderPath = "C:\Users\Jihed\Desktop\jihed\*.xls" 'adapter chemin repertoire et ajouter "\*.xls" pour dire tout les fichiers
'Définit la recherche dans les sous dossiers (True / False)
.SubFolders = False
'Option de tri
.SortBy = sort_Name
strFilesType = msoFileTypeExcelWorkbooks
'Option pour rechercher un type de fichier
.Extension = "*.xls"
'Execute la recherche
If .Execute > 0 Then
'Boucle sur le tableau pour afficher le résultat de la recherche
For i = 1 To .FoundFilesCount
Range("C" & i + 1).Value = .Files(i).strFileType
Next i
End If
' boucle de tri pour les Moule et Gabarit
End With
Application.ScreenUpdating = True 'affiche les rafraîchissements d'écran
End Sub |
Partager