Re : Défi pour les balaises !
'=========================================================================================================
' Créer un classeur avec une feuille vierge que l'on nommera
' Rapports_5h : propriété (Name) sous VBE
'
' Dans environnement VBE
' Recopier l'ensemble du code ci dessous dans un module
' Outils | Références Cocher Microsoft Scripting Runtime
'
' Un bouton est à créer sur la feuille "Rapports_5h"
' il faut le nommer Actualiser et lui affecter la procédure Actualiser_Click
'
' Const Dossier As String = "C:\Transfert\Essais" à modifier pour pointer sur le dossier désiré
'
'=========================================================================================================
Option Explicit
Dim NbFichiers As Integer
' Dossier des classeurs à traiter
Const Dossier As String = "C:\Transfert\Essais"
' On suppose que tous les fichiers contiennent les données dans Feuil1
' Si un onglet ne s'appelle pas NomFeuille
' une erreur #REF! est inscrite dans les cellules concernées
Const NomFeuille As String = "Feuil1"
Private Sub Entete()
With Rapports_5h
' Tout effacer
.Cells.Clear
.Range("A3").Formula = "Fichier"
' A tout hasard cela peut être interessant
' d'avoir ces infos sur les fichiers
.Range("B3") = "Date de Création"
.Range("C3") = "Date Dernière Modification"
'A10 D10 H10 J10 D54 H54
.Range("D3") = "Temp. entrée effluent"
.Range("E3") = "Temp. sortie effluent"
.Range("F3") = "Conductivité entrée effluent"
.Range("G3") = "Volume calamité"
.Range("H3") = "Volume entrée MBBR"
.Range("I3") = "Concentration O2 MBBR"
.Range("J3") = "Temp. Moy. MBR"
.Range("K3") = "pH Moy. MBBR"
.Range("L3") = "Concentration O2 BA"
.Range("M3") = "Volume vers flottateur"
.Range("N3") = "Masse de lait de chaux"
.Range("O3") = "Volume polymère DS"
.Range("P3") = "pH Moy. Cond."
.Range("Q3") = "Volume polymère M"
.Range("R3") = "Temp. Moy. rejet"
.Range("S3") = "pH Moy. rejet"
.Range("T3") = "Volume rejet"
.Range("U3") = "Volume toutes eaux"
.Range("V3") = "Volume boues flottateur"
.Range("W3") = "Volume boues DS"
.Range("X3") = "Volume boues M"
.Range("Y3") = "Volume boues vers centrif."
.Range("Z3") = "Volume polymère centrif."
End With
End Sub
Private Sub ListeFichiersDans(NomDossierSource As String)
Dim FSO As Scripting.FileSystemObject
Dim DossierSource As Scripting.Folder
Dim Fichier As Scripting.file
Dim r As Long
Set FSO = New Scripting.FileSystemObject
Set DossierSource = FSO.GetFolder(NomDossierSource)
NbFichiers = 0
r = Rapports_5h.Range("A65536").End(xlUp).Row + 1
' Balayer le dossier et extraire le nom des fichiers
For Each Fichier In DossierSource.Files
With Rapports_5h
.Cells(r, 1) = Fichier.Name
.Cells(r, 2) = Fichier.DateCreated
.Cells(r, 3) = Fichier.DateLastModified
End With
NbFichiers = NbFichiers + 1
r = r + 1
Next Fichier
Set Fichier = Nothing
Set DossierSource = Nothing
Set FSO = Nothing
End Sub
' Permet de lire une valeur dans un fichier Excel fermé
Private Function ExtraireValeur(ByVal Dossier As String, ByVal Fichier As String, ByVal Feuille As String, ByVal Cellule As String)
Dim Argument As String
Fichier = Replace(Fichier, "'", "''")
Argument = "'" & Dossier & "[" & Fichier & "]" & Feuille & "'!" & Range(Cellule).Address(, , xlR1C1)
ExtraireValeur = ExecuteExcel4Macro(Argument)
End Function
Private Sub Actualiser_Click()
Dim Debut As Variant
Dim NumeroLigne As Integer, i As Integer
Dim NomFichier As String
Dim DDate As String
Dim DossierOk As String
' Par curiosité
Debut = Time
Application.ScreenUpdating = False
Entete
DossierOk = Dossier
' Pour éviter le drame du copier/coller ....
If Right(DossierOk, 1) <> "\" Then DossierOk = DossierOk & "\"
ListeFichiersDans DossierOk
' Si un onglet de NomFichier ne s'appelle pas NomFeuille
' une erreur #REF! est incrite dans les cellules concernées
' On démarre à cette ligne
NumeroLigne = 4
For i = 1 To NbFichiers
NomFichier = Rapports_5h.Range("A" & NumeroLigne)
With Rapports_5h
.Cells(NumeroLigne, 4) = ExtraireValeur(DossierOk, NomFichier, NomFeuille, "G8")
.Cells(NumeroLigne, 5) = ExtraireValeur(DossierOk, NomFichier, NomFeuille, "G9")
.Cells(NumeroLigne, 6) = ExtraireValeur(DossierOk, NomFichier, NomFeuille, "G7")
.Cells(NumeroLigne, 7) = ExtraireValeur(DossierOk, NomFichier, NomFeuille, "G4")
.Cells(NumeroLigne, 8) = ExtraireValeur(DossierOk, NomFichier, NomFeuille, "G5")
.Cells(NumeroLigne, 9) = ExtraireValeur(DossierOk, NomFichier, NomFeuille, "G12")
.Cells(NumeroLigne, 10) = ExtraireValeur(DossierOk, NomFichier, NomFeuille, "G13")
.Cells(NumeroLigne, 11) = ExtraireValeur(DossierOk, NomFichier, NomFeuille, "G14")
.Cells(NumeroLigne, 12) = ExtraireValeur(DossierOk, NomFichier, NomFeuille, "G15")
.Cells(NumeroLigne, 13) = ExtraireValeur(DossierOk, NomFichier, NomFeuille, "G16")
.Cells(NumeroLigne, 14) = ExtraireValeur(DossierOk, NomFichier, NomFeuille, "G31")
.Cells(NumeroLigne, 15) = ExtraireValeur(DossierOk, NomFichier, NomFeuille, "G23")
.Cells(NumeroLigne, 16) = ExtraireValeur(DossierOk, NomFichier, NomFeuille, "G28")
.Cells(NumeroLigne, 17) = ExtraireValeur(DossierOk, NomFichier, NomFeuille, "G24")
.Cells(NumeroLigne, 18) = ExtraireValeur(DossierOk, NomFichier, NomFeuille, "G30")
.Cells(NumeroLigne, 19) = ExtraireValeur(DossierOk, NomFichier, NomFeuille, "G29")
.Cells(NumeroLigne, 20) = ExtraireValeur(DossierOk, NomFichier, NomFeuille, "G33")
.Cells(NumeroLigne, 21) = ExtraireValeur(DossierOk, NomFichier, NomFeuille, "G32")
.Cells(NumeroLigne, 22) = ExtraireValeur(DossierOk, NomFichier, NomFeuille, "G19")
.Cells(NumeroLigne, 23) = ExtraireValeur(DossierOk, NomFichier, NomFeuille, "G21")
.Cells(NumeroLigne, 24) = ExtraireValeur(DossierOk, NomFichier, NomFeuille, "G20")
.Cells(NumeroLigne, 25) = ExtraireValeur(DossierOk, NomFichier, NomFeuille, "G22")
.Cells(NumeroLigne, 26) = ExtraireValeur(DossierOk, NomFichier, NomFeuille, "G25")
' Si Dates à extraire mal formatées
' DDate = ExtraireValeur(DossierOk , NomFichier, NomFeuille, "Cxy" )
' If IsDate(DDate) Then .Cells(NumeroLigne, z) = Format(DDate, "dd/mm/yyyy" )
' Sinon
' .Cells(NumeroLigne, z) = Format(DDate, "dd/mm/yyyy" )
End With
NumeroLigne = NumeroLigne + 1
Application.StatusBar = i & " / " & NbFichiers
Next
Application.StatusBar = "Terminé : " & Format((Time() - Debut) * 100000, "0.00")
' Revenir en haut à gauche
With ActiveWindow
.ScrollRow = 1
.ScrollColumn = 1
End With
With Rapports_5h
.Rows("3:3").Font.Bold = True
.Columns("B:C").Select
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlBottom
End With
.Columns("A:I").Columns.AutoFit
.Range("A1").Select
End With
Application.ScreenUpdating = True
End Sub
Private Sub DispoBoutons()
Dim t As Range
With Rapports_5h
.Activate
.Rows(1).RowHeight = 12.75
.Rows(2).RowHeight = 12.75
Set t = .Cells(1, 3)
With .Buttons("Actualiser")
.Left = t.Left + 3
.Top = t.Top + 5
.Width = t.Width - 6
.Height = Rows(1).RowHeight + Rows(2).RowHeight - 8
End With
End With
End Sub
Private Sub Workbook_Open()
DispoBoutons
With ActiveWindow
.ScrollRow = 1
.ScrollColumn = 1
End With
Rapports_5h.Range("A1").Select
End Sub
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
End Sub
