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
| Option Explicit
Sub Creer_Recapitulatif()
Dim Obj, RepP, Fichier, F1
Dim i As Integer, Lig As Long
Dim Chemin As String
Dim WksDest As Worksheet
Dim wlSource As Worksheet
Dim TB
' Vider la page
Dim a
With ThisWorkbook.Sheets(1)
a = .Range("A1").SpecialCells(xlCellTypeLastCell).Address
With Range("A5:" & a)
.ClearContents
.Interior.Pattern = xlNone
.Borders(xlInsideVertical).LineStyle = xlNone
.Borders(xlInsideHorizontal).LineStyle = xlNone
.Borders(xlEdgeTop).LineStyle = xlNone
End With
End With
'Fin vidé la page
Application.ScreenUpdating = False
TB = Array(" ", "d4", "C5", "K2", "j4", "C6", "C7", "K32", "k33", "k35", "k36", "k37", "k38")
Chemin = "D:\smc\Factures\" 'Adapter le répertoire
Set WksDest = ThisWorkbook.Sheets(1) 'feuille de destination
Lig = WksDest.Cells(Rows.Count, 1).End(xlUp).Row + 1 '1ère ligne où commencer les transferts
Set Obj = CreateObject("Scripting.FileSystemObject")
Set RepP = Obj.GetFolder(Chemin)
Set Fichier = RepP.Files
For Each F1 In Fichier 'boucle sur tout les fichiers du répertoire
If F1 Like "*" Then ' recherche tout les fichiers a partir de l'étoile "*"
Workbooks.Open F1
'Le fichier qu'ont vient d'ouvrir est toujours le fichier actif.
With ActiveWorkbook.Sheets(1) 'Travail avec l'index feuille et pas le nom
For i = 1 To UBound(TB)
WksDest.Cells(Lig, i) = .Range(TB(i))
Next i
'Copie pour avoir aussi le format
'.Range("K9").Copy WksDest.Cells(Lig, i)
'Ferme le classeur sans sauver et sans message.
ActiveWorkbook.Close False
Lig = Lig + 1
End With
End If
Next F1
Set RepP = Nothing
Set Obj = Nothing
End Sub |
Partager