francedemo
XLDnaute Occasionnel
bonjour à tous,
grâce au forum, j'ai assemblé de plusieurs sources un code qui fonctionne bien pour lister les fichiers d'un répertoire avec informations sur le contenu de chaque fichier (en fait, ça crée un sorte de BdD pour récapituler des données)
voici le code utilisé
comme vous pouvez le voir dans le code, je fais des aller-retour entre le fichier ouvert à l'instant "t" et le fichier récap.
je voudrai savoir s'il n'existe pas une autre façon de faire pour éviter ces aller-retour gourmand en temps (la macro mets 90 sec pour faire le boulot sur mon répertoire qui n'est pas très gros = 140 fichiers)
d'avance merci
grâce au forum, j'ai assemblé de plusieurs sources un code qui fonctionne bien pour lister les fichiers d'un répertoire avec informations sur le contenu de chaque fichier (en fait, ça crée un sorte de BdD pour récapituler des données)
voici le code utilisé
Code:
Sub ListeFichiersContenu()
'macro par francedemo
Dim Fichier As String
Dim NomFichier As String
Dim Chemin As String
Dim Derligne As Long
Dim DerLigneA As Long
debut = Timer 'ça permet de voir le temps passé
Workbooks("ListeDevis.xls").Activate
'===Nettoyer la zone et sélectionner la cellule de début
Range("A2:F65536").Clear
Range("A2").Activate
'===Saisir le chemin complet du dossier où se trouvent les fichiers
Chemin = "\\Serveur\DATA\CARDIO\SAV\DevisSAV\"
'===Premier fichier
Fichier = Dir(Chemin & "*.xls")
Do While Fichier <> ""
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.EnableEvents = False
If Fichier <> "ListeDevis.xls" Then
Workbooks.Open Filename:=Chemin & Fichier
'===Inserer lien hypertexte "Lien Fichier" + Copie de "Livraison"
Windows(Fichier).Activate
Range("G6").Copy
Workbooks("ListeDevis.xls").Activate
Sheets("Base").Select
Derligne = Range("F65536").End(xlUp).Row + 1
NomFichier = Left(Fichier, Len(Fichier) - 5)
ActiveWorkbook.ActiveSheet.Hyperlinks.Add _
Anchor:=Cells(Derligne, 1), Address:=Chemin & Fichier, _
TextToDisplay:=NomFichier
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 "Nb"
Windows(Fichier).Activate
Range("A13:A23").Copy
Workbooks("ListeDevis.xls").Activate
Sheets("Base").Select
Range("E" & Derligne).PasteSpecial _
Paste:=xlPasteValues, _
Operation:=xlNone, _
SkipBlanks:=False, _
Transpose:=False
'===Copie de "Désignation"
Windows(Fichier).Activate
Range("B13:B23").Copy
Workbooks("ListeDevis.xls").Activate
Sheets("Base").Select
Range("F" & Derligne).PasteSpecial _
Paste:=xlPasteValues, _
Operation:=xlNone, _
SkipBlanks:=False, _
Transpose:=False
'===Insérer une ligne après chaque fichier
Derligne = Range("F65536").End(xlUp).Row
Range("A" & Derligne, "F" & 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
End If
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("F" & n) = "" Then Rows(n).Delete
Next n
'===Mise en forme des colonnes
Range("A2", "A" & Derligne + 1).ColumnWidth = 50
Range("B2", "C" & Derligne + 1).ColumnWidth = 40
Range("D2", "D" & Derligne + 1).ColumnWidth = 25
Range("E2", "F" & Derligne + 1).EntireColumn.AutoFit
With Selection.Font
.Name = "Arial"
.Size = 12
End With
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Application.EnableEvents = True
Application.CutCopyMode = False
Range("A2").Activate
MsgBox ("Terminé en " & Timer - debut & " seconde(s)")
End Subcomme vous pouvez le voir dans le code, je fais des aller-retour entre le fichier ouvert à l'instant "t" et le fichier récap.
je voudrai savoir s'il n'existe pas une autre façon de faire pour éviter ces aller-retour gourmand en temps (la macro mets 90 sec pour faire le boulot sur mon répertoire qui n'est pas très gros = 140 fichiers)
d'avance merci
