francedemo
XLDnaute Occasionnel
bonjour à tous,
j'utilise un code pour créer un fichier récap qui récupère la liste des fichiers d'un répertoire.
la macro renseigne automatiquement un certain nb d'info dont le nom du fichier en lien hypertexte
le pb est que le lien hypertexte apparait en taille 7.5 (ça je le corrige dans la macro) mais surtout, j'ai le chemin complet qui s'affiche donc la taille de cellule est très importante et en plus, l'utilisateur n'a pas besoin de lire tout le chemin du fichier correspondant, je voudrai que seul le nom du fichier s'affiche (sans le .xls, qui ne sert pas non plus, si possible)
ci dessous le code utilisé:
j'utilise un code pour créer un fichier récap qui récupère la liste des fichiers d'un répertoire.
la macro renseigne automatiquement un certain nb d'info dont le nom du fichier en lien hypertexte
le pb est que le lien hypertexte apparait en taille 7.5 (ça je le corrige dans la macro) mais surtout, j'ai le chemin complet qui s'affiche donc la taille de cellule est très importante et en plus, l'utilisateur n'a pas besoin de lire tout le chemin du fichier correspondant, je voudrai que seul le nom du fichier s'affiche (sans le .xls, qui ne sert pas non plus, si possible)
ci dessous le code utilisé:
Code:
Sub ListeFichiersContenu()
Dim Fichier As String
Dim Chemin As String
Dim Derligne As Long
debut = Timer
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Workbooks("ListeDevis.xls").Activate
'Nettoyer la zone et sélectionner la cellule de début
Range("A2:G10000").Clear
Range("A2").Activate
'Saisir le chemin complet du dossier où se trouvent les fichiers
Chemin = "O:\xxx\xxxxx\" '(chemin modifié)
'Premier fichier
Fichier = Dir(Chemin & "*.xls")
Do While Fichier <> ""
Application.DisplayAlerts = False
Workbooks.Open Filename:=Chemin & Fichier
'Inserer lien hypertexte + Copie de "Livraison"
Windows(Fichier).Activate
Range("G6").Copy
Workbooks("ListeDevis.xls").Activate
Sheets("Base").Select
Derligne = Range("E65000").End(xlUp).Row + 1
ActiveWorkbook.ActiveSheet.Hyperlinks.Add _
Anchor:=Cells(Derligne, 1), Address:=Chemin & Fichier
Range("B" & Derligne).PasteSpecial _
Paste:=xlPasteValuesAndNumberFormats, _
Operation:=xlNone, _
SkipBlanks:=False, _
Transpose:=False
'Copie de "Facturation"
Windows(Fichier).Activate
Range("Q6").Copy
Workbooks("ListeDevis.xls").Activate
Sheets("Base").Select
Range("C" & Derligne).PasteSpecial _
Paste:=xlPasteValuesAndNumberFormats, _
Operation:=xlNone, _
SkipBlanks:=False, _
Transpose:=False
'Copie de "matériel"
Windows(Fichier).Activate
Range("H3").Copy
Workbooks("ListeDevis.xls").Activate
Sheets("Base").Select
Range("D" & Derligne).PasteSpecial _
Paste:=xlPasteValues, _
Operation:=xlNone, _
SkipBlanks:=False, _
Transpose:=False
'Copie de "Désignation"
Windows(Fichier).Activate
Range("B13:B20").Copy
Workbooks("ListeDevis.xls").Activate
Sheets("Base").Select
Range("E" & Derligne).PasteSpecial _
Paste:=xlPasteValues, _
Operation:=xlNone, _
SkipBlanks:=False, _
Transpose:=False
'Insérer une ligne après chaque fichier
Derligne = Range("E65000").End(xlUp).Row
Range("A" & Derligne, "E" & Derligne).Select
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.Weight = xlMedium
.ColorIndex = 6
End With
'Fermeture du fichier Devis ouvert
Windows(Fichier).Activate
Application.CutCopyMode = False
ActiveWorkbook.Close savechanges:=False
'Fichier suivant
Fichier = Dir
Loop
'Fin de la boucle
Workbooks("ListeDevis.xls").Activate
'Nettoyage des lignes vides
Sheets("Base").Select
For n = Derligne + 10 To 2 Step -1
If Range("E" & n) = "" Then Rows(n).Delete
Next n
'Mise en forme des colonnes
Range("B2", "E" & Derligne + 1).EntireColumn.AutoFit
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Range("A2").Activate
MsgBox ("Terminé en " & Timer - debut & " seconde(s)")
End Sub