Sub Collecte()
'
' Procédure enregistrée le 14 Brumaire CCXVII (4/11/2008) par ROGER2327
' Procédure modifiée le 17 Floréal CCXXII (6/5/2014) par ROGER2327
' Procédure modifiée le 18 Floréal CCXXII (7/5/2014) par ROGER2327
'
'
Dim i&, j&, k&, tf As Boolean
Dim param_des_fichiers, chemin$, fichier$, feuille$, msg$, cf$, n&, h&, u, v()
With Application: .ScreenUpdating = 0: .EnableEvents = 0: .Calculation = -4135: End With
On Error GoTo Ea
ThisWorkbook.Sheets("RECAP").[A1].CurrentRegion.Offset(1).ClearContents
param_des_fichiers = ThisWorkbook.Sheets("PARAM").[A1].CurrentRegion.Value
ReDim v(4 To UBound(param_des_fichiers, 2))
If UBound(param_des_fichiers, 1) > 1 Then
For i = 2 To UBound(param_des_fichiers, 1)
If Not IsEmpty(param_des_fichiers(i, 4)) Then
tf = True
chemin = param_des_fichiers(i, 1)
If Right$(chemin, 1) <> "\" Then chemin = chemin & "\"
fichier = param_des_fichiers(i, 2)
feuille = param_des_fichiers(i, 3)
cf = Dir(chemin)
Do While cf <> ""
u = Empty
If cf = fichier Then
tf = False
Workbooks.Open Filename:=chemin & fichier
With ActiveWorkbook
For j = .Worksheets.Count To 1 Step -1
If .Worksheets(j).Name = feuille Then
With Worksheets(j)
With .Columns(param_des_fichiers(i, 4)).Cells(1, 1)
With .Parent.Range(.Cells, IIf(IsEmpty(.Cells) Or IsEmpty(.Cells.Offset(1)), .Cells, .End(xlDown)))
h = .Count * (1 + IsEmpty(.Cells(1, 1).Value))
End With
End With
If h Then
For k = 4 To UBound(v)
If Not IsEmpty(param_des_fichiers(i, k)) Then v(k) = .Columns(param_des_fichiers(i, k)).Cells(1, 1).Resize(h).Cells
Next
End If
End With
Exit For
End If
Next j
.Close
End With
If j Then
With ThisWorkbook.Sheets("RECAP").[A2].Offset(n)
If h Then
For k = 5 To UBound(v): .Offset(, k - 5).Resize(h).Value = v(k): Next
n = n + h
Else
msg = msg & vbLf & "Il n'y a pas de données dans la feuille """ & feuille & """ du classeur " & vbLf & Chr(9) & """" & fichier & """."
End If
End With
Else
msg = msg & vbLf & "Il n'y a pas de feuille """ & feuille & """ dans le classeur " & vbLf & Chr(9) & """" & fichier & """."
End If
End If
cf = Dir
Loop
If tf Then msg = msg & vbLf & "Il n'existe pas de chemin " & vbLf & Chr(9) & """" & chemin & fichier & """."
End If
Next i
Else
msg = msg & vbLf & "Il n'y a aucun dossier à traiter."
End If
ThisWorkbook.Sheets("RECAP").Activate
Fa:
With Application: .Calculation = -4105: .EnableEvents = 1: .ScreenUpdating = 1: End With
If msg <> "" Then MsgBox msg, vbInformation
Exit Sub
Ea:
If Not (ActiveWorkbook Is ThisWorkbook) Then ActiveWorkbook.Close
msg = "Une erreur imprévue s'est produite !"
Resume Fa
End Sub