Option Explicit
Sub Recuperation()
Dim nomfichier$, chemin$, tablo As Range, ligne1 As Byte, colPlus As Byte
Dim h As Byte, L As Byte, lig As Byte, ouv As Boolean, w As Worksheet, i As Long
Application.ScreenUpdating = False
'---à adapter éventuellement---
nomfichier = "heure à recuperer test.xls"
chemin = ThisWorkbook.Path & "\" & nomfichier
With ThisWorkbook.Sheets("Stat")
Set tablo = .[A6:G6].Resize(.[A200].End(xlUp).Row - 6)
End With
ligne1 = 5 '1ère ligne de tablo à remplir
colPlus = 4 'colonne "Plus"
'---initialisation---
h = tablo.Rows.Count
L = tablo.Columns.Count
lig = ligne1
tablo.Rows(lig & ":" & h).ClearContents 'effacement des données
tablo.Offset(, L).Resize(, 133).Clear 'pour 19 tableaux de 7 colonnes...
'---ouverture du fichier s'il n'est pas ouvert---
On Error Resume Next
If IsError(Workbooks(nomfichier).Name) Then
If IsError(Workbooks.Open(chemin)) Then _
MsgBox "'" & nomfichier & "' est introuvable !", 48: Exit Sub
ouv = True 'repère
End If
On Error GoTo 0
'---étude des feuilles du fichier et transferts---
Application.Calculation = xlManual 'évite le recalcul des formules
For Each w In Workbooks(nomfichier).Worksheets
If w.Name <> "Général" Then
For i = 2 To w.Cells(65536, 1).End(xlUp).Row - 1
If w.Cells(i, 1) = Date Then
If lig > h Then 'extension du tableau
tablo.Copy tablo.Offset(, L)
Set tablo = tablo.Offset(, L)
lig = ligne1
tablo.Rows(lig & ":" & h).ClearContents
End If
tablo.Cells(lig, 1) = w.Name
tablo.Cells(lig, colPlus) = w.Cells(i, "B")
tablo.Cells(lig, colPlus + 1) = w.Cells(i, "E")
lig = lig + 1
End If
Next
End If
Next
Application.Calculation = xlAutomatic
'---fermeture du fichier s'il a été ouvert---
If ouv Then Workbooks(nomfichier).Close False
End Sub