Option Explicit
Sub RecupJ1()
Dim oWb1 As Workbook, oWb2 As Workbook, oWs1 As Worksheet, oWs2 As Worksheet
Dim i%, Rw As Long, Cr$(4 To 27), j%, c%, Ong$, Fich, Dos$, Ent%(4 To 27)
'initialisation classeur et feuille receveuse
Set oWb1 = ThisWorkbook: Set oWs1 = ActiveSheet
'dernière ligne écrite
Rw = oWs1.Cells(Rows.Count, 1).End(xlUp).Row
'tableau adresse des cellules
Cr(4) = "A4": Cr(5) = "K2": Cr(6) = "A6": Cr(7) = "C7": Cr(8) = "C298": Cr(9) = "C303"
Cr(10) = "D311": Cr(11) = "C312": Cr(12) = "D314": Cr(13) = "C315": Cr(14) = "C11": Cr(15) = "D53"
Cr(16) = "C123": Cr(17) = "D177": Cr(18) = "C209": Cr(19) = "D253": Cr(20) = "C268": Cr(21) = "C324"
Cr(22) = "D325": Cr(23) = "C326": Cr(24) = "K22": Cr(25) = "K26": Cr(26) = "K28": Cr(27) = "K16"
'tableau type cellules à récupérer (1-> valeur à convertir en heure/minutes)
Ent(6) = 1: Ent(14) = 1: Ent(24) = 1: Ent(26) = 1
'ouvrir un classeur
Fich = Application.GetOpenFilename("(*.xls), *.xls")
'quitter si click annuler
If Fich = False Then Exit Sub
'initialisation classeur source
Set oWb2 = Workbooks.Open(Fich)
'pour chaque caractère du nom long du fichier
For i = 1 To Len(Fich)
'au 1er "\" rencontré à droite
If Left(Right(Fich, i), 1) = "\" Then
'récupère nom du dossier et quitte la boucle
Dos = Left(Fich, Len(Fich) - i)
Exit For
End If
Next i
'pour chaque feuille
For i = 1 To oWb2.Worksheets.Count
'si son nom comporte 3 caractères au plus
If Len(oWb2.Worksheets(i).Name) < 4 Then
'ajuster ligne d'écriture et compteur de cellules récupérées pour la feuille en cours
Rw = Rw + 1: c = 0
'écritures colonnes 1 à 3
oWs1.Cells(Rw, 1) = oWb2.Name
oWs1.Cells(Rw, 2) = Dos
oWs1.Cells(Rw, 3) = oWb2.Worksheets(i).Name
'pour chaque élément du tableau adresse
For j = LBound(Cr) To UBound(Cr)
'écriture de la cellule correspondante si non vide et ajustement compteur
If oWb2.Worksheets(i).Range(Cr(j)) <> "" Then
c = c + 1
'si valeur à convertir
If Ent(j) = 1 Then
'format
oWs1.Cells(Rw, j).NumberFormat = "[h]:mm:ss"
'valeur lue est en minutes
oWs1.Cells(Rw, j) = oWb2.Worksheets(i).Range(Cr(j)) / 1440
Else
oWs1.Cells(Rw, j) = oWb2.Worksheets(i).Range(Cr(j))
End If
End If
Next j
'si rien n'a été récupéré pour cette feuille suppression de la ligne et ajustement ligne d'écriture
If c = 0 Then
oWs1.Rows(Rw).Delete: Rw = Rw - 1
End If
End If
Next i
Workbooks(oWb2.Name).Close
End Sub