Importation de données à partir de plusieurs fichiers Excel

Le 15/05/2019 à 06:16

Bonjour à tous,

Je suis novice en VBA et je tente d'écrire depuis quelques jours, un code qui me permettra d'importer le contenu de plusieurs fichiers dans un tout nouveau fichier.

Le contexte

J'ai environ 300 fichiers sous lesquels je dois extraire des données,

La totalité des fichiers sources est logée sous un même répertoire dans l'entreprise et les fichiers commencent tous par le chiffre "1"

Chaque fichier possède plusieurs feuilles,

Les données qui sont à extraire (28 cellules) sont toutes sous la même feuille (onglet) intitulée "Résultat". Cependant, certaines manipulations doivent être effectuées afin d'aligner les informations à extraire sur la même ligne, pour éventuellement en faciliter l'exportation vers le tout nouveau fichier intitulé "Tableau Consolidé.xlsm".

Le nouveau fichier aura une seule feuille (onglet) qui importera les 300 lignes d'informations sous un tableau.

Le code recherché doit :

Ouvrir chaque fichier sur la feuille "Résultat"

Effectuer six (6) manipulations d'informations (voir la macro ci-jointe)

Sub CréationNouvDatas()
'
' CréationNouvDatas Macro

' Copier les informations du COST - Temps par livre

    Range("H33:H35").Select
    Selection.Copy
    ActiveWindow.SmallScroll ToRight:=3
    ActiveWindow.SmallScroll Down:=10
    ActiveWindow.SmallScroll ToRight:=4
    Range("S50").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=True
    ActiveWindow.SmallScroll ToRight:=-7

' Copier les informations du COST - Au pied carré

    Range("H36:H37").Select
    Application.CutCopyMode = False
    Selection.Copy
    ActiveWindow.SmallScroll ToRight:=8
    Range("V50").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=True

' Copier les informations du VENDANT - Temps par livre

    Range("I33:I35").Select
    Application.CutCopyMode = False
    Selection.Copy
    Range("X50").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=True
    ActiveWindow.SmallScroll ToRight:=5
    ActiveWindow.LargeScroll ToRight:=-1

' Copier les informations du VENDANT - Au pied carré

    Range("I36:I37").Select
    Application.CutCopyMode = False
    Selection.Copy
    ActiveWindow.LargeScroll ToRight:=1
    Range("AA50").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=True
    ActiveWindow.SmallScroll ToRight:=-15

' Enlever le remplissage de couleur noire

    Rows("49:50").Select
    Range("J49").Activate
    Application.CutCopyMode = False
    With Selection.Interior
        .Pattern = xlNone
        .TintAndShade = 0
        .PatternTintAndShade = 0
    End With
    Range("a50").Select

' Copier toute la ligne d'informations à transférer dans le nouveau tableau

    Range("A50:AP50").Select
    Application.CutCopyMode = False
    Selection.Copy

 End Sub

Ouvrir le nouveau fichier "Tableau Consolidé" qui reçoit les informations à la feuille (onglet) "Données"

Insérer une nouvelle ligne dans le tableau existant

Copier les informations préalablement exportées du fichier source (voir la macro ci-jointe)

Sub TransfertInfos

' Importation des données dans nouveau fichier

    Windows("Tableau Consolidé.xlsm").Activate
    Sheets("Données").Select
    Rows("2:2").Select
    Selection.Insert Shift:=xlDown
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
        SkipBlanks:=False, Transpose:=False

 End Sub

Fermer le premier fichier source sans sauvegarder

Ouvrir le second fichier source

Répéter les étapes précédentes jusqu'au dernier fichier inclus dans le répertoire.

Les multiples essais

J'ai effectué plusieurs recherches et utilisé des parcelles de code utilisant les notions de LOOP avec DO WHILE. Malheureusement, je n'arrive pas à construire le code adéquatement. Je reconnais mon manque de compréhension des principes du codage VBA et j'avoue humblement que les derniers jours ont soulevé quelques frustrations.

En conclusion, je passe le flambeau à un de vous, mais je souhaite ardemment comprendre et développer l'art du codage VBA, car j'ai d'autres défis qui se présenteront au cours des prochains mois.

Merci de votre généreuse collaboration.

Le 15/05/2019 à 07:58

Bonjour,

Pas facile sans aucun fichier pour tester donc, je te laisse les tests. Il te faut mettre tout le code ci-dessous dans un module standard du classeur "Tableau Consolidé.xlsm" et exécuter la sub "Consolider" en ayant au préalable adapter le chemin du dossier où se trouvent les classeurs (variable "Dossier") et le nom de la feuille du classeur "Tableau Consolidé.xlsm" à la ligne de code :

Cl.Worksheets("Feuil1").Cells(K, J).Value = TValeurs(1, J)

Sub Consolider()

    'Important, cette porcédure doit être dans le classeur "Tableau Consolidé.xlsm" !

    Dim TC As Workbook
    Dim Cl As Workbook
    Dim TValeurs() As Variant
    Dim Tbl() As String
    Dim Dossier As String
    Dim I As Integer
    Dim J As Integer
    Dim K As Integer

    Dossier = "C:\Mon dossier\" 'adapter le chemin

    Set TC = ThisWorkbook '"<--- Tableau Consolidé.xlsm"

    'récupère les chemins et noms des différents classeurs
    Tbl = EnumFichiers(Dossier)

    'si trouvés...
    If Not (Not Tbl) Then

        'ouvre les classeurs
        For I = 1 To UBound(Tbl)

            Set Cl = Workbooks.Open(Tbl(I))

            K = K + 1

            'récupère les différentes valeurs...
            TValeurs = ManipRecup(Cl)

            '...puis les inscrit dans la feuille nommée "Feuil1" du classeur "Tableau Consolidé.xlsm", adapter si nom différent !
            For J = 1 To UBound(TValeurs, 2)

                Cl.Worksheets("Feuil1").Cells(K, J).Value = TValeurs(1, J)

            Next I

            'ferme sans enregistrer
            Cl.Close False

        Next I

    Else

        MsgBox "Aucun fichier correspondant dans le dossier '" & Dossier & "' !"

    End If

End Sub

Function ManipRecup(Cl As Workbook) As Variant()

    With Cl.Worksheets("Résultat")

        'Copier les informations du COST - Temps par livre
        .Range("S50:U50").Value = Application.Transpose(.Range("H33:H35").Value)

        'Copier les informations du COST - Au pied carré
        .Range("V50:W50").Value = Application.Transpose(.Range("H36:H37").Value)

        'Copier les informations du VENDANT - Temps par livre
        .Range("X50:Z50").Value = Application.Transpose(.Range("I33:I35").Value)

        'Copier les informations du VENDANT - Au pied carré
        .Range("AA50:AB50").Value = Application.Transpose(.Range("I36:I37").Value)

        'Copier toute la ligne d'informations à transférer dans le nouveau tableau
        ManipRecup = .Range("A50:AP50").Value

    End With

End Function

Function EnumFichiers(Chemin As String) As String()

    Dim TableauFichiers() As String
    Dim Fichier As String
    Dim I As Integer

    If Right(Chemin, 1) <> "\" Then Chemin = Chemin & "\"

    'récupère les fichiers Excel et ceux commençant par 1
    Fichier = Dir(Chemin & "1*.xls*")

    Do While (Len(Fichier) > 0)

        I = I + 1: ReDim Preserve TableauFichiers(1 To I)

        TableauFichiers(I) = Chemin & Fichier

        Fichier = Dir()

    Loop

    EnumFichiers = TableauFichiers()

End Function
Le 15/05/2019 à 14:33

Bonjour Theze,

Premièrement, merci pour ta collaboration dans ma quête. J'apprécie grandement les notes explicatives. C'est instructif!

Je comprends qu'il est effectivement difficile de tester sans fichier complémentaire. Cependant, j'ai testé le tout à mon arrivée au bureau et j'ai rencontré une petite erreur de compilation au premier "Next I".

Voici le code adapté avec le chemin. Afin de tester le VBA, j'ai créé une feuille "Onglet" intitulée "Feuil1" dans le fichier de réception.

Sub Consolider()

    'Important, cette porcédure doit être dans le classeur "Tableau Consolidé.xlsm" !

    Dim TC As Workbook
    Dim Cl As Workbook
    Dim TValeurs() As Variant
    Dim Tbl() As String
    Dim Dossier As String
    Dim I As Integer
    Dim J As Integer
    Dim K As Integer

    Dossier = "O:\PROPOSITION 2019\" 'adapter le chemin

    Set TC = ThisWorkbook '"<--- Tableau Consolidé.xlsm"

    'récupère les chemins et noms des différents classeurs
    Tbl = EnumFichiers(Dossier)

    'si trouvés...
    If Not (Not Tbl) Then

        'ouvre les classeurs
        For I = 1 To UBound(Tbl)

            Set Cl = Workbooks.Open(Tbl(I))

            K = K + 1

            'récupère les différentes valeurs...
            TValeurs = ManipRecup(Cl)

            '...puis les inscrit dans la feuille nommée "Feuil1" du classeur "Tableau Consolidé.xlsm", adapter si nom différent !
            For J = 1 To UBound(TValeurs, 2)

                Cl.Worksheets("feuil1").Cells(K, J).Value = TValeurs(1, J)

            Next I

            'ferme sans enregistrer
            Cl.Close False

        Next I

    Else

        MsgBox "Aucun fichier correspondant dans le dossier '" & Dossier & "' !"

    End If

End Sub

Function ManipRecup(Cl As Workbook) As Variant()

    With Cl.Worksheets("Résultat")

        'Copier les informations du COST - Temps par livre
        .Range("S50:U50").Value = Application.Transpose(.Range("H33:H35").Value)

        'Copier les informations du COST - Au pied carré
        .Range("V50:W50").Value = Application.Transpose(.Range("H36:H37").Value)

        'Copier les informations du VENDANT - Temps par livre
        .Range("X50:Z50").Value = Application.Transpose(.Range("I33:I35").Value)

        'Copier les informations du VENDANT - Au pied carré
        .Range("AA50:AB50").Value = Application.Transpose(.Range("I36:I37").Value)

        'Copier toute la ligne d'informations à transférer dans le nouveau tableau
        ManipRecup = .Range("A50:AP50").Value

    End With

End Function

Function EnumFichiers(Chemin As String) As String()

    Dim TableauFichiers() As String
    Dim Fichier As String
    Dim I As Integer

    If Right(Chemin, 1) <> "\" Then Chemin = Chemin & "\"

    'récupère les fichiers Excel et ceux commençant par 1
    Fichier = Dir(Chemin & "1*.xls*")

    Do While (Len(Fichier) > 0)

        I = I + 1: ReDim Preserve TableauFichiers(1 To I)

        TableauFichiers(I) = Chemin & Fichier

        Fichier = Dir()

    Loop

    EnumFichiers = TableauFichiers()

End Function

Lors de mes multiples tentatives, j'ai effectivement rencontré des situations similaires.

Merci de ta contribution.

Le 15/05/2019 à 16:09

Oups,

Désolé, comme je n'est pas testé

Il faut modifier la variable de contrôle dans la boucle interne :

For J = 1 To UBound(TValeurs, 2)

    Cl.Worksheets("feuil1").Cells(K, J).Value = TValeurs(1, J)

Next J '<--- ici, il faut mettre J et non I car déjà utilisée !
Le 15/05/2019 à 17:35

Aucun problème!

Modification faite et petit "bog" à la ligne,

'...puis les inscrit dans la feuille nommée "Feuil1" du classeur "Tableau Consolidé.xlsm", adapter si nom différent !
            For J = 1 To UBound(TValeurs, 2)

               Cl.Worksheets("feuil1").Cells(K, J).Value = TValeurs(1, J) ' <-------- Ligne nécessitant un débogage...

            Next J

            'ferme sans enregistrer
            Cl.Close False

        Next I

Le message d'erreur indique :

Erreur d'exécution '9' :

L'indice n'appartient pas à la sélection.

et en appuyant sur le bouton "débogage" l'outil débogage nous dirige à la ligne en question.

Mes observations :

  • L'ouverture du 1er fichier à traiter s'effectue correctement.
  • Les données portant sur les informations du COST (Temps par livre + Au pied carré) se transpose dans les bonnes cellules de la ligne 50 de la feuille de manipulation.

Il semble que la procédure VBA s'arrête là. Il n'y a aucune donnée pour le volet du VENDANT et le fichier source demeure ouvert.

En espérant ces indices utiles et constructifs.

Au risque de me répéter, un gros merci de ta généreuse collaboration.

Le 16/05/2019 à 06:48

Bonjour,

Bon, cette fois-ci j'ai construis trois classeurs pour les tests et apporté les corrections pour que ça fonctionne. Je poste juste la procédure "Consolider()", les deux fonctions n'ayant pas été modifiées :

Sub Consolider()

    'Important, cette porcédure doit être dans le classeur "Tableau Consolidé.xlsm" !

    Dim TC As Workbook
    Dim Cl As Workbook
    Dim TValeurs() As Variant
    Dim Tbl() As String
    Dim Dossier As String
    Dim I As Integer
    Dim J As Integer
    Dim K As Integer

    Application.ScreenUpdating = False

    Dossier = "O:\PROPOSITION 2019\" 'adapter le chemin

    Set TC = ThisWorkbook '"<--- Tableau Consolidé.xlsm"

    'récupère les chemins et noms des différents classeurs
    Tbl = EnumFichiers(Dossier)

    'si trouvés...
    If Not (Not Tbl) Then

        'ouvre les classeurs
        For I = 1 To UBound(Tbl)

            Set Cl = Workbooks.Open(Tbl(I))

            K = K + 1

            'récupère les différentes valeurs...
            TValeurs = ManipRecup(Cl)

            '...puis les inscrit dans la feuille nommée "Feuil1" du classeur "Tableau Consolidé.xlsm", adapter si nom différent !
            For J = 1 To UBound(TValeurs, 2)

                TC.Worksheets("Feuil1").Cells(K, J).Value = TValeurs(1, J)

            Next J

            'ferme sans enregistrer
            Cl.Close False

        Next I

    Else

        MsgBox "Aucun fichier correspondant dans le dossier '" & Dossier & "' !"

    End If

    Application.ScreenUpdating = True

End Sub
Le 16/05/2019 à 19:47

Bonjour Theze,

C'est nickel!!! Tout fonctionne. Félicitations.

Cependant, il y a un aspect qui m'avait échappé dans ma requête initiale. Certains fichiers .xls* ont des liaisons avec d'autres classeurs. Cette situation provoque une intervention manuelle afin de répondre de "NE PAS METTRE À JOUR LES LIAISONS".

Serait-il possible de résoudre cette situation par un bout de code, pour les fichiers. xls* concernés?

Merci!

Le 17/05/2019 à 06:38

Bonjour,

Essais avec "DisplayAlerts = False" :

Sub Consolider()

    'Important, cette porcédure doit être dans le classeur "Tableau Consolidé.xlsm" !

    Dim TC As Workbook
    Dim Cl As Workbook
    Dim TValeurs() As Variant
    Dim Tbl() As String
    Dim Dossier As String
    Dim I As Integer
    Dim J As Integer
    Dim K As Integer

    Application.ScreenUpdating = False
    Application.DisplayAlerts = False

    Dossier = "O:\PROPOSITION 2019\" 'adapter le chemin

    Set TC = ThisWorkbook '"<--- Tableau Consolidé.xlsm"

    'récupère les chemins et noms des différents classeurs
    Tbl = EnumFichiers(Dossier)

    'si trouvés...
    If Not (Not Tbl) Then

        'ouvre les classeurs
        For I = 1 To UBound(Tbl)

            Set Cl = Workbooks.Open(Tbl(I))

            K = K + 1

            'récupère les différentes valeurs...
            TValeurs = ManipRecup(Cl)

            '...puis les inscrit dans la feuille nommée "Feuil1" du classeur "Tableau Consolidé.xlsm", adapter si nom différent !
            For J = 1 To UBound(TValeurs, 2)

                TC.Worksheets("Feuil1").Cells(K, J).Value = TValeurs(1, J)

            Next J

            'ferme sans enregistrer
            Cl.Close False

        Next I

    Else

        MsgBox "Aucun fichier correspondant dans le dossier '" & Dossier & "' !"

    End If

    Application.DisplayAlerts = True
    Application.ScreenUpdating = True

End Sub
Le 31/05/2019 à 13:04

Bonjour,

J'ai ajouter la portion "DisplayAlert = False" et ça n'a malheureusement pas fonctionné.

Si vous pensez à une autre approche, je suis toujours preneur.

Merci à vous.

Rechercher des sujets similaires à "importation donnees partir fichiers"