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
5releves-meteo.zip (136.63 Ko)

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
Rechercher des sujets similaires à "collecter donnees fiches"