Collecter des données de plusieurs fiches
Bonjour,
Il arrive que nous soyons en possession de nombreuses fiches "standardisées" mais néanmoins individuelles et qui ne permettent pas d'avoir une vue de synthèse, d'en faire une analyse et prendre des actions.
Exemples :
- factures
- rapports de laboratoires
- rapports d'essai
- relevés individuels
- etc.
Si les moyens éditent souvent des fiches pdf, elles n'en conservent pas moins des fiches au format xls dans leur propre disque interne.
Le programme ci-dessous permet de regrouper les informations dans une pseudo-base de données (tableau).
Il suffit ensuite, à la première compilation de données, d'ajouter les formules as-hoc (des champs sont laissés libres lorsque non renseignés en dehors de l'en-tête du tableau) et la mise en forme, celles-ci seront conservées pour les prochaines compilations.
La collecte des données se fait sans ouverture des fichiers (si ceux-ci sont en calcul automatique).
Option Explicit
' Mike STEELSON
Dim onglet As String, prefixe As String, nbcarprefixe As Integer, ouverturefichier As Boolean, nonLien As Boolean
Dim col, nbColonnes As Integer
Dim cel, celDebLigne As Range
Dim MonRepertoire As String, lig As Long
Sub Lecture()
With Sheets("parametres")
If .Range("debut").Value = "" Then
MsgBox "Aucune donnée à relever !"
Exit Sub
End If
' mise en place des paramètres du programme
MonRepertoire = .Range("repertoire").Value
onglet = .Range("onglet").Value
prefixe = .Range("prefixe").Value
nbcarprefixe = .Range("nbcarprefixe").Value
ouverturefichier = False
If .Range("calculauto").Value = "NON" Then ouverturefichier = True
nonLien = False
If .Range("liensactifs").Value = "NON" Then nonLien = True
' activation de la feuille de données
Sheets("data").Select
If .Range("RAZ").Value = "OUI" Then
If Not ActiveSheet.ListObjects(1).DataBodyRange Is Nothing Then ActiveSheet.ListObjects(1).DataBodyRange.Delete
End If
' nbre de colonnes et mise en place des en-tetes de colonnes
nbColonnes = 0
Cells(1, 1) = "Fichier source"
For Each cel In .Range("debut:" & Range("debut").End(xlToRight).Address)
nbColonnes = nbColonnes + 1
Cells(1, nbColonnes + 1) = cel.Value
Next cel
' lecture du répertoire
ListeFichiers MonRepertoire
' fin du programme
Cells.Select
Cells.EntireColumn.AutoFit
Cells.Font.Underline = xlUnderlineStyleNone
Range("A1").Select
Application.CutCopyMode = False
MsgBox "Compilation des données terminée ! " & lig - 2 & " lignes récupérées"
' enchainement sur programme spécifique
' si besoin
End With
End Sub
Sub ListeFichiers(Repertoire As String)
If Repertoire = "" Then
MsgBox "Choisir un répertoire !"
Exit Sub
End If
Dim Fso, SourceFolder, SubFolder, fichier As Object
Dim depuis As String, jusque As String
Set Fso = CreateObject("Scripting.FileSystemObject")
Set SourceFolder = Fso.GetFolder(Repertoire)
Sheets("data").Select
With Sheets("parametres")
' récupère le numéro de la dernière ligne vide dans la colonne A.
lig = Range("A" & Rows.Count).End(xlUp).Row + 1
If Range("A2") = "" Then lig = 2
' boucle sur tous les fichiers du répertoire
For Each fichier In SourceFolder.Files
If Right(fichier.Name, 4) = ".xls" Or Right(fichier.Name, 5) = ".xlsx" Or Right(fichier.Name, 5) = ".xlsm" Then
If Left(fichier.Name, 2) <> "~$" And Left(fichier.Name, nbcarprefixe) = prefixe Then
'... debut acces fichier
If ouverturefichier Then Workbooks.Open Filename:=Repertoire & "\" & fichier.Name
ThisWorkbook.Activate
depuis = Range("B" & lig).Address
For Each celDebLigne In .Range(.Range("debut").Offset(1, 0).Address & ":" & .Range("debut").End(xlDown).Address)
Cells(lig, 1) = "vers ... " & fichier.Name 'fichier.ParentFolder & "\" & fichier.Name
ActiveSheet.Hyperlinks.Add Anchor:=Cells(lig, 1), Address:=fichier.ParentFolder & "\" & fichier.Name
col = 1
For Each cel In .Range(celDebLigne.Address & ":" & Range(celDebLigne.Address).Offset(0, nbColonnes - 1).Address)
col = col + 1
If cel.Value <> "" Then Cells(lig, col) = " '" & Repertoire & "\[" & fichier.Name & "]" & onglet & "'!" & cel.Value & " "
Next cel
lig = lig + 1
Next celDebLigne
jusque = Range("B" & lig - 1).Offset(0, col - 2).Address
' activation de la formule en ajoutant =
Range(depuis, jusque).Select
Selection.Replace What:=" '", Replacement:="= '", LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False
If nonLien Then
Selection.Copy
Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
End If
If ouverturefichier Then Workbooks(fichier.Name).Close SaveChanges:=False
'... fin acces fichier
End If
End If
Next fichier
' appel récursif pour les sous-répertoires
For Each SubFolder In SourceFolder.subfolders
ListeFichiers SubFolder.Path
Next SubFolder
End With
End Sub
Sub select_repertoire()
Dim Repertoire As FileDialog
Set Repertoire = Application.FileDialog(msoFileDialogFolderPicker)
Repertoire.Show
If Repertoire.SelectedItems.Count > 0 Then
Range("repertoire").Value = Repertoire.SelectedItems(1)
End If
End Sub
Exemple avec quelques fiches "météo" d'uns station imaginaire dont les données hebdo sont transmises chaque lundi.
Révision du code ...
Option Explicit
' Mike STEELSON
Dim onglet As String, prefixe As String, nbcarprefixe As Integer, data As ListObject
Dim col As Integer, nbColonnes As Integer
Dim cel As Range, debut As Range
Sub Lecture()
With Sheets("parametres")
If .Range("debut").Value = "" Then
MsgBox "Aucune donnée à relever !"
Exit Sub
End If
' mise en place des paramètres du programme
onglet = .Range("onglet").Value
prefixe = .Range("prefixe").Value
nbcarprefixe = .Range("nbcarprefixe").Value
' activation de la feuille de données
Sheets("data").Select
Set data = ActiveSheet.ListObjects(1)
If .Range("RAZ").Value = "OUI" Then
If Not data.DataBodyRange Is Nothing Then data.DataBodyRange.Delete
End If
' nbre de colonnes et mise en place des en-tetes de colonnes
nbColonnes = 0
data.HeaderRowRange.Cells(1, 1) = "Fichier source"
For Each cel In .Range("debut:" & Range("debut").End(xlToRight).Address)
nbColonnes = nbColonnes + 1
data.HeaderRowRange.Cells(1, 1).Offset(0, nbColonnes) = cel.Value
Next cel
' lecture du répertoire
ListeFichiers .Range("repertoire").Value
' fin du programme
Cells.Select
Cells.EntireColumn.AutoFit
Cells.EntireRow.AutoFit
Cells.Font.Underline = xlUnderlineStyleNone
Cells(1, 1).Select
Application.CutCopyMode = False
MsgBox "Compilation des données terminée ! " & data.ListRows.Count & " lignes récupérées"
' enchainement sur programme spécifique
' si besoin
End With
End Sub
Sub ListeFichiers(Repertoire As String)
If Repertoire = "" Then
MsgBox "Choisir un répertoire !"
Exit Sub
End If
Dim Fso, SourceFolder, SubFolder, fichier As Object
Set Fso = CreateObject("Scripting.FileSystemObject")
Set SourceFolder = Fso.GetFolder(Repertoire)
With Sheets("parametres")
Sheets("data").Select
' boucle sur tous les fichiers du répertoire
For Each fichier In SourceFolder.Files
If Right(fichier.Name, 4) = ".xls" Or Right(fichier.Name, 5) = ".xlsx" Or Right(fichier.Name, 5) = ".xlsm" Then
If Left(fichier.Name, 2) <> "~$" And Left(fichier.Name, nbcarprefixe) = prefixe Then
'... debut acces fichier
If .Range("calculauto").Value = "NON" Then Workbooks.Open Filename:=Repertoire & "\" & fichier.Name
ThisWorkbook.Activate
For Each debut In .Range(.Range("debut").Offset(1, 0).Address & ":" & .Range("debut").End(xlDown).Address)
data.ListRows.Add
data.DataBodyRange.Cells(data.ListRows.Count, 1) = "vers ... " & fichier.Name
ActiveSheet.Hyperlinks.Add Anchor:=data.DataBodyRange.Cells(data.ListRows.Count, 1), Address:=fichier.ParentFolder & "\" & fichier.Name
col = 1
For Each cel In .Range(debut.Address & ":" & Range(debut.Address).Offset(0, nbColonnes - 1).Address)
col = col + 1
If cel.Value <> "" Then data.DataBodyRange.Cells(data.ListRows.Count, col) = " '" & Repertoire & "\[" & fichier.Name & "]" & onglet & "'!" & cel.Value & " "
Next cel
Next debut
' activation de la formule en ajoutant =
data.DataBodyRange.Select
Selection.Replace What:=" '", Replacement:="= '", LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False
If .Range("liensactifs").Value = "NON" Then
Selection.Copy
Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
End If
If .Range("calculauto").Value = "NON" Then Workbooks(fichier.Name).Close SaveChanges:=False
'... fin acces fichier
End If
End If
Next fichier
' appel récursif pour les sous-répertoires
For Each SubFolder In SourceFolder.subfolders
ListeFichiers SubFolder.Path
Next SubFolder
End With
End Sub
Sub select_repertoire()
Dim Repertoire As FileDialog
Set Repertoire = Application.FileDialog(msoFileDialogFolderPicker)
Repertoire.Show
If Repertoire.SelectedItems.Count > 0 Then
Range("repertoire").Value = Repertoire.SelectedItems(1)
End If
End Sub
Nouvelle optimisation du code
Option Explicit
' Mike STEELSON
Dim onglet As String, nomfic As String, nbcarnomfic As Integer, data As ListObject
Dim col As Integer, nbColonnes As Integer
Dim cel As Range, debut As Range
Sub Lecture()
Dim repertoire As String
With Sheets("parametres")
If .Range("debut").Value = "" Then
MsgBox "Aucune donnée à relever !"
Exit Sub
End If
If Range("repertoire").Value = "" Then
MsgBox "Choisir un répertoire !"
Exit Sub
End If
' mise en place des paramètres du programme
onglet = .Range("onglet").Value
nomfic = .Range("nomfic").Value
' activation de la feuille de données
Sheets("data").Select
Set data = ActiveSheet.ListObjects(1)
If .Range("RAZ").Value = "OUI" Then
If Not data.DataBodyRange Is Nothing Then data.DataBodyRange.Delete
End If
' nbre de colonnes et mise en place des en-tetes de colonnes
nbColonnes = 0
For Each cel In .Range("debut:" & Range("debut").End(xlToRight).Address)
data.HeaderRowRange.Cells(1, 1).Offset(0, nbColonnes) = cel.Value
nbColonnes = nbColonnes + 1
Next cel
If .Range("versfichier").Value = "OUI" Then data.HeaderRowRange.Cells(1, 1).Offset(0, nbColonnes) = "Fichier source"
' lecture du répertoire
ListeFichiers .Range("repertoire").Value
' fin du programme
Cells.Select
Cells.EntireColumn.AutoFit
Cells.EntireRow.AutoFit
Cells.Font.Underline = xlUnderlineStyleNone
Cells(1, 1).Select
Application.CutCopyMode = False
MsgBox "Compilation des données terminée ! " & data.ListRows.Count & " lignes récupérées"
' enchainement sur programme spécifique si besoin
End With
End Sub
Sub ListeFichiers(repertoire As String)
Dim Fso, SourceFolder, SubFolder, fichier As Object
Set Fso = CreateObject("Scripting.FileSystemObject")
Set SourceFolder = Fso.GetFolder(repertoire)
With Sheets("parametres")
Sheets("data").Select
' boucle sur tous les fichiers du répertoire
For Each fichier In SourceFolder.Files
If Right(fichier.Name, 4) = ".xls" Or Right(fichier.Name, 5) = ".xlsx" Or Right(fichier.Name, 5) = ".xlsm" Then
If Left(fichier.Name, 2) <> "~$" And fichier.Name Like "*" & nomfic & "*" Then
'... debut acces fichier
If .Range("calculauto").Value = "NON" Then Workbooks.Open Filename:=repertoire & "\" & fichier.Name
ThisWorkbook.Activate
For Each debut In .Range(.Range("debut").Offset(1, 0).Address & ":" & .Range("debut").End(xlDown).Address)
data.ListRows.Add
col = 1
For Each cel In .Range(debut.Address & ":" & Range(debut.Address).Offset(0, nbColonnes - 1).Address)
If cel.Value <> "" Then data.DataBodyRange.Cells(data.ListRows.Count, col) = " '" & repertoire & "\[" & fichier.Name & "]" & onglet & "'!" & cel.Value & " "
col = col + 1
Next cel
If .Range("versfichier").Value = "OUI" Then
data.DataBodyRange.Cells(data.ListRows.Count, col) = "vers ... " & fichier.Name
ActiveSheet.Hyperlinks.Add Anchor:=data.DataBodyRange.Cells(data.ListRows.Count, col), Address:=fichier.ParentFolder & "\" & fichier.Name
End If
Next debut
' activation de la formule en ajoutant =
data.DataBodyRange.Select
Selection.Replace What:=" '", Replacement:="= '", LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False
If .Range("liensactifs").Value = "NON" Then
Selection.Copy
Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
End If
If .Range("calculauto").Value = "NON" Then Workbooks(fichier.Name).Close SaveChanges:=False
'... fin acces fichier
End If
End If
Next fichier
' appel récursif pour les sous-répertoires
For Each SubFolder In SourceFolder.subfolders
ListeFichiers SubFolder.Path
Next SubFolder
End With
End Sub
Sub select_repertoire()
Dim repertoire As FileDialog
Set repertoire = Application.FileDialog(msoFileDialogFolderPicker)
repertoire.Show
If repertoire.SelectedItems.Count > 0 Then
Range("repertoire").Value = repertoire.SelectedItems(1)
End If
End Sub