XL 2016 Macro consolidation plusieurs fichiers en 1 seul

[Alan28]

Bonjour à tous,

Je reviens vers vous parce que je n'arrive pas à mettre au point une macro de consolidation. J'ai réussi à la faire fonctionner mais elle ne me prend pas toutes les lignes des fichiers... en plus elle me copie aussi les entêtes des colonnes. Cela n'est pas très grave car je peux les supprimer rapidement en effectuant un filtre mais le problème est qu'elle ne me prend pas les lignes que je lui demande.

Ce que je veux qu'elle fasse :
- Ouvrir chaque fichier du répertoire
- Effectuer un filtre sur la colonne L et sélectionner le résultat Oui
- Copier-Coller les lignes concernées dans le fichier de consolidation

Ci-joint quelques fichiers pour exemple, le résultat que la Macro donne après son lancement et le résultat attendu (celui-ci je l'ai effectué à la main).
Au passage, serait-il possible d'éliminer le nom de l'onglet ? Dans ce type de fichier il y aura toujours qu'un seul onglet (extraction d'un CRM).

Ci-dessus le code VBA :

Sub Copier_CourbesAD_REV()

    
    Dim DerLig As Long
    Dim Ligbas As Long
        Dim StrFile, chemin As String
        
    'Il faut mettre ici le chemin de ton répertoire
    chemin = "\\gad.intra.net\fr\Profils\Utilisateurs\alan\Desktop\Nouveau dossier\"
    StrFile = Dir(chemin & "*.xlsx*")
  
    Application.DisplayAlerts = False
    Application.ScreenUpdating = False
  
    Do While Len(StrFile)
      
        With Workbooks.Open(chemin & StrFile)
    
      
'##################sélectionner les données de chaque écriture

'mettre le nom de la feuille
'Sheets("Report 1 - Rapport détaillé").Select


 
 
      
    
    With Sheets("Report 1 - Rapport détaillé")
        DerLig = .Range("a" & Rows.Count).End(xlUp).Row
        .Range("A1:L" & DerLig).AutoFilter
        .Range("$A$1:L" & DerLig).AutoFilter Field:=11, Criteria1:="OUI"
    
 End With
 
With ActiveSheet
DerLig = Range("A" & Rows.Count).End(xlUp).Row
Range("A1:L" & DerLig).Copy

Set Wb = ActiveWorkbook


End With


'ActiveWorkbook.Close SaveChanges=False 'Fermer
      
        
        


'copier les données dans le fichier de validation



Windows("fichier-consolidation-lignes.xlsb").Activate
Sheets("Sayfa1").Select
With ActiveSheet
Ligbas = Range("A" & Rows.Count).End(xlUp).Row + 1

  Cells(Ligbas, "A").Select
  Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
        End With


ThisWorkbook.Save
 
        
        

      
       End With
 
  Application.DisplayAlerts = False
 Wb.Close False
 Application.DisplayAlerts = False
 
 
    StrFile = Dir
    Loop
    
    
    'Call ferme
    
End Sub

Je vous remercie par avance pour votre aide.

Alan.

 

[Hasco]

Bonjour,

Seulement 1 ou deux fichiers suffisaient !

Voici une solution par Power Query (Onglet 'Données / Obtenir des données / A partir d'un fichier / A partir d'un dossier).

Mettez vos 5 fichiers dans un répertoire, même s'il y en a d'autres. La requête sélectionnera seulement les fichier dont le nom commence par 'Fichier n°'.
Ouvrez le fichier 'Résultats attendu', puis sélectionnez une cellule du tableau de la feuille 'nautes',
voyez l'onglet 'Requête' qui apparaît dans le bandeau excel. Dans ce onglet, cliquez sur le bouton modifier.

L'éditeur Power Query s'ouvrira sur la requête. Dans son panneau de droite sélectionnez l'étape nommée 'Source' et dans sa barre de formule, changez le nom du répertoire où se trouve les fichiers.

Par la suite nous pourrons, si ce répertoire change, le mettre en paramètre.

Validez puis fermer l'éditeur Power Query en cliquant sur le bouton 'Fermer et charger'.

Attention, dans l'un de vos fichier (j'ai pas vu lequel) la colonne de sélection ne doit pas avoir tout à fait le même nom que dans les autres fichiers et Power query travaille beaucoup sur les noms de colonne. Chez moi j'ai modifié un à un le noms des colonnes "
"Demande rechargement
répertoire
OUI
NON"

De plus vous avez des cellules qui contiennent "OUI" et d'autres "oui" ! Ce qui est différent pour Power Query. (La sélection ce fait après mise en majuscule)

 

[Alan28]

Bonjour @Roblochon, je vous remercie pour votre retour. Malheureusement la solution proposée ne m’aide pas puisque je n’ai pas Power Query et je ne pourrais pas l’avoir sur la version d’Excel que j’utilise en entreprise. Il va falloir vraiment que je résolus ce problème avec une macro…
Quelqu’un aurait-il une idée comment je peux résoudre cette macro ? Je vous remercie.

 

[Hasco]

Bonjour,

Alors faisons le à l'ancienne. Voici une méthode qui utilise Adodb et une petite fonction personnelle pour lister les fichiers.

Mettez vos fichier dans le même répertoire que celui qui contient la macro ou changer le chemin vers les fichiers

Voir le bouton sur la feuille 'Adodb'

Je n'utilise pas les noms de colonnes des feuilles mais les noms par défaut attribués par adodb (F1 à F12) au cas où ils ne correspondent pas exactement d'un fichier à l'autre.

Les lignes s'ajouteront aux lignes existantes s'il y en a.

Sub Consolidation()
'
' Objets de connexion et récupération des données
    Dim Cnx As Object, Rst As Object
    '
    ' Liste de fichier et item de fichier
    Dim Fichiers As Variant, item As Variant
    Dim ligne As Long
    '
    ' Récupérer la liste des fichiers
    Fichiers = ListeFichiers("Fichier n°*.xls?")
    '
    ' Si pas de fichiers alors prévenir et sortir
    If IsEmpty(Fichiers) Then
        MsgBox "Aucun fichier trouvé dans le répertoire", vbExclamation, "Consolidation"
        Exit Sub
    End If
 
    '
    ' Créer un object connection
    Set Cnx = CreateObject("adodb.connection")
    '
    ' Traiter chaque item de la liste
    For Each item In Fichiers
        ' Initialiser la connexion au fichier
        Cnx.connectionstring = Replace(Replace(CNX_STRING, "[DatasSource]", item), "?", "NO")
        Cnx.cursorlocation = 3
        '
        ' Ouvir la connexion
        Cnx.Open
        '
        ' création de l'objet recordset
        Set Rst = CreateObject("adodb.recordset")
        '
        ' l'ouvrir et interroger les données
        Rst.Open SQL, Cnx
        '
        ' s'il a trouvé quelque chose
        If Not Rst.BOF And Not Rst.EOF Then
            '
            ' Copier les lignes du recordset dans la prochaine ligne disponible
            ThisWorkbook.Sheets("Adodb").Cells(Rows.Count, 1).End(xlUp)(2).CopyFromRecordset Rst
            '
            ' Fermer et détruire proprement les objets adodb
            Rst.Close
            Set Rst = Nothing
        End If
        '
        ' Ne pas oublier de fermer la connexion au fichier en cours
        ' avant de passer au suivant
        Cnx.Close
    Next
    '
    ' détruire l'objet connexion
    Set Cnx = Nothing
End Sub

Function ListeFichiers(strFiltre As String) As Variant
    Dim res() As String
    Dim item As String
    Dim i As Long
    Dim Répertoire As String: Répertoire = ThisWorkbook.Path & "\"
    item = Dir(Répertoire & strFiltre)
    Do While item <> ""
        i = i + 1
        ReDim Preserve res(1 To i)
        res(i) = Répertoire & item
        item = Dir
    Loop
    ListeFichiers = IIf(i > 0, res, Empty)
End Function

cordialement

 

[Alan28]

Bonjour @Roblochon, je vous remercie à nouveau pour votre retour. Pardonnez-moi mais je ne vois pas où indiquer le chemin de mon repertoire dans la macro. Serait-il possible de m’indiquer où le mettre ?
Je vous remercie par avance.

ÉDIT: J’ai indiqué dans « Répertoire =ThisWorkbook.Path & “chemin du répertoire où se trouvent les fichiers\” mais cela ne semble pas fonctionner car j’ai toujours le messagebox « Aucun fichier trouvé dans le répertoire ».

 

[Hasco]

Re,

Dans la fonction ListeFichiers à la ligne :

Dim Répertoire As String: Répertoire = ThisWorkbook.Path & "\"

ThisWorkbook.Path est le chemin du classeur qui contient la macro. Si vous voulez un autre chemin cela pourrait être en dur :

Dim Répertoire As String: Répertoire ="ZZZ:\Excel\XLD\nautes\"

Les noms de vos fichiers correspondent-ils au masque "Fichier n°*.xls?" où * représente plusieurs caractères ("Fichier n°1" aussi bien que "Fichier n°AA589642")
et ? un seul caractère (pour .xlsx, .xlsm etc)

si vos noms de fichiers ne correspondent pas à ce masque, il ne seront pas trouvés.
Eventuellement dites-nous à quoi ils ressemblent


Cordialement

 

[Alan28]

Bonjour @Roblochon, toutes mes excuses pour cette réponses tardive. Le nom des fichiers est le suivant : Rapport_détaillé_Dupont. Il peut en avoir plusieurs rapports, seulement le nom du client qui change. Mais sinon chaque fichier aura dans son nom "Rapport_détaillé_".
Je vous remercie.

 

[Hasco]

Bonjour @Roblochon, toutes mes excuses pour cette réponses tardive. Le nom des fichiers est le suivant : Rapport_détaillé_Dupont. Il peut en avoir plusieurs rapports, seulement le nom du client qui change. Mais sinon chaque fichier aura dans son nom "Rapport_détaillé_".
Je vous remercie.

Bonjour,

Eh bien mettez pour masque de recherche : "Rapport_détaillé_*.xls?" qui recherchera tous les fichiers du répertoire dont le nom commence par "Rapport_détaillé_" suivi de 1 à n caractères(s) autorisé dans un nom de fichier et enfin suivi d'une des extensions excel. Exemple : Rapport_Détaillé_Alan28.xlsx
Rapport_Détaillé_28Alan.xls
Rapport_Détaillé_A7la9n.xlsm

cordialement

 

[Alan28]

Bonjour @Roblochon, c'est parfait. La macro fonctionne parfaitement, je vous remercie encore une fois pour l'aide que vous m'avez apporté.
Bien à vous,
Alan.