Recherche sur plusieurs Fichiers

Bonjour à tous,

Étant toujours débutant en VBA je me permets de vous demander un peu d'aide car là je rame un peu!

J'ai une problématique : j'ai un certains nombre de classeurs dans lesquels je dois aller chercher des données spécifiques en fonction de différents critères, et je dois restituer ces données sur un seul et même classeur dans des onglets différents (qui correspondent aux critères).

Ce que j'aimerai faire :

J'ai uniquement 4 critères mais une multitude de classeurs donc je souhaiterai en une macro, parcourir tous mes classeurs, si le critère "1" est trouvé, je veux qu'une feuille nommée "1" soit créée automatiquement sur mon classeur de restitution et que les données y soient collées les unes à la suite des autres, et ainsi de suite. Si le critère "2" est trouvé alors il colle les valeurs correspondantes sur une feuille automatiquement générée nommée "2" Etc.

J'ai réussit à faire une macro fonctionnelle "basique" mais je souhaiterai l'améliorer pour tout faire en un seul traitement

En gros ma macro ouvre tous les classeurs sur une feuille standardisée (cela ne bougera jamais), fait une recherche (IF) sur un seul critère que j'ai déterminé, me copie la ligne trouvée et la restitue dans un autre classeur sur une feuille créée manuellement.

En fait je répond à ma problématique, mais en ayant créé 4x la même macro pour mes 4 critères et pour coller ces données sur 4 feuilles différentes... (que je lance en une seule macro avec des Call)

Donc c'est plus de la curiosité pour m'améliorer en VBA

Voici mon code actuel qui fonctionne pour un seul critère

Au passage, dans mon code actuel j'ai mis 2-3 HELP car je n'arrive pas à automatiser mon code à certain moment.

Pouvez-vous m'indiquer des pistes pour arriver à mes fins ?

Merci énormément à vous

Sub RECHERCHE()

Dim wb As Workbook
Dim ws, ws_1 As Worksheet
Dim DerLig, DerCol As Integer
Dim Chemin, Fichier As String
Dim j As Integer

Application.ScreenUpdating = False 'OK - désactive la mise à jour de l'écran
Application.DisplayAlerts = False 'OK - désactive les messages d'alertes

Chemin = "H:\Dossier_data\" 'OK - Chemin des fichiers à ouvrir
Fichier = Dir(Chemin & "*.xlsx") 'OK - Selection des fichiers .xlsx uniquement

Set ws = Worksheets("RESTITUTION") 'OK - Détermine le nom le l'onglet où seront restituer les valeurs

i = 6
ws.Range("B" & i & ":ZZ1000").ClearContents 'OK - Supprimer les valeurs de B5:ZZ1000
    'HELP - Je souhaiterai automatiser "ZZ1000" en déterminant automatiquement la dernière ligne et colonne non vide
ws.Range("B" & i & ":ZZ1000").UnMerge 'OK - Supprime les fusions de cellules
    'HELP - Je souhaiterai intégrer cette manipulation à la ligne de code du dessus si possible

    Do While Fichier <> "" 'OK - Boucle sur "Fichier"

Set wb = Workbooks.Open(Chemin & Fichier) 'OK - Ouvre le fichier "Fichier".xlsx du repertoire "Chemin"
Set ws_1 = wb.Worksheets("A_EXTRAIRE") 'OK - Se place sur la feuille "A_EXTRAIRE" du classeur ouvert

        For L = 4 To ws_1.Range("A" & Rows.Count).End(xlUp).Row 'OK - Parcours la plage A4 à la dernière ligne non vide de la colonne A
            If ws_1.Range("A" & L).Value = ws.Range("B2").Value Then 'OK - Si la valeur de A"L" de la feuille ws_1 = B2 de la feuille ws
            ws_1.Range("B" & L & ":BO" & L).Copy 'OK - Copie la plage B"L" jusqu'a "BO"L de la feuille ws_1
            'HELP¨- Je soutaierai automatiser "BO" en déterminant la dernière colonne non vide de la ligne L
            ws.Activate 'OK - Active le feuille ws ("RESTITUTION")
            ws.Range("B" & i).Select 'OK - Selectionne la cellule B"i" de la feuille ws
            ActiveSheet.Paste 'OK - Colle les valeurs
            i = i + 1 'OK - rajoute 1 à la valeur de "i" pour ne pas écraser les valeurs précedement copiées
            End If 'OK - Fin de la condition
        Next L 'OK - Boucle sur la valeur du L
    wb.Close 'OK - Ferme le classeur wb ouvert sans enregistrement
    Fichier = Dir
    Loop 'Boucle sur le fichier .xlsx suivant
End Sub

Bonsoir Ju, bonsoir le forum,

Difficile de t'aider sans avoir les autres critères...

Bonsoir ThauThème,

On peut considérer que les critères sont "1", "2", "3", "4".

Et ils se trouvent toujours dans la colonne "A" des fichiers sur une feuille nommée "A_EXTRAIRE"

Merci d'avance pour l'aide

Re,

Désolé pour le retard. Peu disponible en ce moment...

Peut-être comme ça :

Sub RECHERCHE()
Dim CD As Workbook 'déclare la variable CD (Classeur Destination)
Dim OD As Worksheet 'déclare la variable OS (Onglet Destination)
Dim CA As String 'déclare la variable CA (Chemin d'Accès)
Dim F As strin 'déclare la variable F (Fichier)
Dim CS As worksbook 'déclare la variable CS (Classeur Source)
Dim OS As Worksheet 'déclare la variable OS (Onglet Source)
Dim I As Integer 'déclare la variable CS (Classeur Source)
Dim DEST As Range 'déclare la variable CS (Classeur Source)

Application.ScreenUpdating = False 'masque les rafraîchissemetns d'écran
Application.DisplayAlerts = False 'désactive les messages d'alertes Excel
Set CD = ThisWorkbook 'définit le classeur destination CD
CA = "H:\Dossier_data\" 'définit le chemin d'accès CA
F = Dir(CA & "*.xlsx") 'définit le premier fichier F .xlsx ayant CA comme chemin d'accès
Do While F <> "" 'boucle tant qu'il existe des fichiers
    Set CS = Workbooks.Open(Chemin & F) 'définit la classeur source CS an l'ouvrant
    Set OS = CS.Worksheets("A_EXTRAIRE") 'définit l'onglet source OS
    'boucle sur toutes les cellules éditées de la colonne A de l'onglet source OS en partant de la 4ème
    For I = 4 To OS.Cells(Application.Rows.Count, "A").End(xlUp).Row
        Select Case OS.Cells(I, "A") 'agit en fonction de la valeur de la cellule de la boucle
            Case "1" 'cas "1"
                On Error Resume Next 'gestion des erreurs (en cas d'erreur passe à la ligne suivante)
                Set OD = CD.Worksheets("1") 'définit l'onglet destination OD (génère une erreur si cet onglet n'existe pas)
                If Err <> 0 Then 'condition : si une erreur a été générée
                    CD.Worksheets.Add After:=Sheets(Sheets.Count) 'ajoute une onglet vierge en dernière position
                    Set OD = ActiveSheet 'définit l'onglet destination OD
                    OD.Name = "1" 'nomme l'ongflet OD
                End If 'fin de la condition
                On Error GoTo 0 'annule la gestion des erreurs
                'définit la cellule de destination DEST (B1 si B1 est vide, sinon, la première cellule vide de la colonne B de l'onglet OD)
                Set DEST = IIf(OD.Range("B1") = "", OD.Range("B1"), OD.Cells(Application.Rows.Count, "B").End(xlUp).Offset(1, 0))
                OS.Cells(I, "B").Resize(1, 66).Copy DEST 'copie la cellule B de la boucle redimensionnée et la colle dans DEST
            Case "2" 'cas "2"
                On Error Resume Next 'idem
                Set OD = CD.Worksheets("2") 'idem
                If Err <> 0 Then 'idem
                    CD.Worksheets.Add After:=Sheets(Sheets.Count) 'idem
                    Set OD = ActiveSheet 'idem
                    OD.Name = "2" 'idem
                End If 'idem
                On Error GoTo 0 'idem
                Set DEST = IIf(OD.Range("B1") = "", OD.Range("B1"), OD.Cells(Application.Rows.Count, "B").End(xlUp).Offset(1, 0)) 'idem
                OS.Cells(I, "B").Resize(1, 66).Copy DEST 'idem
            Case "3" 'idem
                On Error Resume Next 'idem
                Set OD = CD.Worksheets("3") 'idem
                If Err <> 0 Then 'idem
                    CD.Worksheets.Add After:=Sheets(Sheets.Count) 'idem
                    Set OD = ActiveSheet 'idem
                    OD.Name = "3" 'idem
                End If 'idem
                On Error GoTo 0 'idem
                Set DEST = IIf(OD.Range("B1") = "", OD.Range("B1"), OD.Cells(Application.Rows.Count, "B").End(xlUp).Offset(1, 0)) 'idem
                OS.Cells(I, "B").Resize(1, 66).Copy DEST 'idem
            Case "4" 'idem
                On Error Resume Next 'idem
                Set OD = CD.Worksheets("4") 'idem
                If Err <> 0 Then 'idem
                    CD.Worksheets.Add After:=Sheets(Sheets.Count) 'idem
                    Set OD = ActiveSheet 'idem
                    OD.Name = "4" 'idem
                End If 'idem
                On Error GoTo 0 'idem
                Set DEST = IIf(OD.Range("B1") = "", OD.Range("B1"), OD.Cells(Application.Rows.Count, "B").End(xlUp).Offset(1, 0)) 'idem
                OS.Cells(I, "B").Resize(1, 66).Copy DEST 'idem
        End Select 'fin de l'action en en fonction de la valeur de la cellule de la boucle
    Next I 'prochaine ligne de la boucle
    CS.Close False 'Ferme le classeur source sans enregistrer
    F = Dir 'définit le prochain fichier .xlsx ayant CA comme chemin d'accès
Loop 'Boucle sur le fichier .xlsx suivant
Application.ScreenUpdating = True 'Affiche les rafraîchissemetns d'écran
Application.DisplayAlerts = True 'active les messages d'alertes Excel
End Sub

Merci ThauThème,

J'ai un petit soucis avec ton code que je n'arrive pas à corriger. Pourtant la syntaxe me parait bien paramétrée

Quand j’exécute la Macro, il ouvre bien le premier classeur, sur la feuille "A_Extraire", cependant il renomme cette feuille "A_Extraire"' en "1" sur ce même classeur, et effectue le copier coller de la ligne sur cette même feuille. Et non dans mon classeur de destination, où la feuille "1" aurai dû être créé.

Je ne comprends pas pourquoi il ne retourne pas sur le classeur de destination CD défini par ThisWorkbook, et la feuille CD.Worksheets("1") que tu crées avec un IF si elle n'existe pas

Set CD = ThisWorkbook 'définit le classeur destination CD
CA = "H:\Dossier_data\" 'définit le chemin d'accès CA
F = Dir(CA & "*.xlsx") 'définit le premier fichier F .xlsx ayant CA comme chemin d'accès
Do While F <> "" 'boucle tant qu'il existe des fichiers
    Set CS = Workbooks.Open(Chemin & F) 'définit la classeur source CS an l'ouvrant
    Set OS = CS.Worksheets("A_EXTRAIRE") 'définit l'onglet source OS
    'boucle sur toutes les cellules éditées de la colonne A de l'onglet source OS en partant de la 4ème
    For I = 4 To OS.Cells(Application.Rows.Count, "A").End(xlUp).Row
        Select Case OS.Cells(I, "A") 'agit en fonction de la valeur de la cellule de la boucle
            Case "1" 'cas "1"
                On Error Resume Next 'gestion des erreurs (en cas d'erreur passe à la ligne suivante)
                Set OD = CD.Worksheets("1") 'définit l'onglet destination OD (génère une erreur si cet onglet n'existe pas)
                If Err <> 0 Then 'condition : si une erreur a été générée
                    CD.Worksheets.Add After:=Sheets(Sheets.Count) 'ajoute une onglet vierge en dernière position
                    Set OD = ActiveSheet 'définit l'onglet destination OD
                    OD.Name = "1" 'nomme l'ongflet OD
                End If 'fin de la condition
                On Error GoTo 0 'annule la gestion des erreurs
                'définit la cellule de destination DEST (B1 si B1 est vide, sinon, la première cellule vide de la colonne B de l'onglet OD)
                Set DEST = IIf(OD.Range("B1") = "", OD.Range("B1"), OD.Cells(Application.Rows.Count, "B").End(xlUp).Offset(1, 0))
                OS.Cells(I, "B").Resize(1, 66).Copy DEST 'copie la cellule B de la boucle redimensionnée et la colle dans DEST

Pour aller plus loin encore et simplifier la macro, j'ai parcouru d'autres tuto qui exploite le code :

MotCle = Array("1", "2", "3","4")

For I = 0 To UBound(MotCle)

Est-ce qu'en partant de ça je peux tout faire avec un seul IF ? sans passer par les 4 cas ?

Merci pour tes éclaircissements,

Cdt,

Re,

Je pense que comme le classeur actif est le classeur source CS, puisqu'on l'ouvre en dernier. il a considéré Activesheet comme étant l'onglet actif du classeur actif CS. J'ai rajouté CD.Activate pour résoudre ce problème. À tester...

Pour ce qui est du Array on pourrais l'utiliser si on était sûr que les onglets existent au préalable. Mais ce n'est pas le cas, au premier lancement de la macro, ils sont créés à la volée. Il y a plusieurs chemins pour arriver à ses fins et chacun de nous a ses petites manies... Et aussi, ce Array ne correspond pas à ta requête initiale :

J'ai uniquement 4 critères mais une multitude de classeurs donc je souhaiterai en une macro, parcourir tous mes classeurs, si le critère "1" est trouvé, je veux qu'une feuille nommée "1" soit créée automatiquement sur mon classeur de restitution et que les données y soient collées les unes à la suite des autres, et ainsi de suite. Si le critère "2" est trouvé alors il colle les valeurs correspondantes sur une feuille automatiquement générée nommée "2" Etc.

Le code modifié :

Sub RECHERCHE()
Dim CD As Workbook 'déclare la variable CD (Classeur Destination)
Dim OD As Worksheet 'déclare la variable OD (Onglet Destination)
Dim CA As String 'déclare la variable CA (Chemin d'Accès)
Dim F As String 'déclare la variable F (Fichier)
Dim CS As worksbook 'déclare la variable CS (Classeur Source)
Dim OS As Worksheet 'déclare la variable OS (Onglet Source)
Dim I As Integer 'déclare la variable CS (Classeur Source)
Dim DEST As Range 'déclare la variable DEST (cellule de DESTination)

Application.ScreenUpdating = False 'masque les rafraîchissemetns d'écran
Application.DisplayAlerts = False 'désactive les messages d'alertes Excel
Set CD = ThisWorkbook 'définit le classeur destination CD
CA = "H:\Dossier_data\" 'définit le chemin d'accès CA
F = Dir(CA & "*.xlsx") 'définit le premier fichier F .xlsx ayant CA comme chemin d'accès
Do While F <> "" 'boucle tant qu'il existe des fichiers
    Set CS = Workbooks.Open(Chemin & F) 'définit la classeur source CS an l'ouvrant
    Set OS = CS.Worksheets("A_EXTRAIRE") 'définit l'onglet source OS
    'boucle sur toutes les cellules éditées de la colonne A de l'onglet source OS en partant de la 4ème
    CD.Activate 'active le classeur destination CD
    For I = 4 To OS.Cells(Application.Rows.Count, "A").End(xlUp).Row
        Select Case OS.Cells(I, "A") 'agit en fonction de la valeur de la cellule de la boucle
            Case "1" 'cas "1"
                On Error Resume Next 'gestion des erreurs (en cas d'erreur passe à la ligne suivante)
                Set OD = CD.Worksheets("1") 'définit l'onglet destination OD (génère une erreur si cet onglet n'existe pas)
                If Err <> 0 Then 'condition : si une erreur a été générée
                    CD.Worksheets.Add After:=Sheets(Sheets.Count) 'ajoute une onglet vierge en dernière position
                    Set OD = ActiveSheet 'définit l'onglet destination OD
                    OD.Name = "1" 'nomme l'ongflet OD
                End If 'fin de la condition
                On Error GoTo 0 'annule la gestion des erreurs
                'définit la cellule de destination DEST (B1 si B1 est vide, sinon, la première cellule vide de la colonne B de l'onglet OD)
                Set DEST = IIf(OD.Range("B1") = "", OD.Range("B1"), OD.Cells(Application.Rows.Count, "B").End(xlUp).Offset(1, 0))
                OS.Cells(I, "B").Resize(1, 66).Copy DEST 'copie la cellule B de la boucle redimensionnée et la colle dans DEST
            Case "2" 'cas "2"
                On Error Resume Next 'idem
                Set OD = CD.Worksheets("2") 'idem
                If Err <> 0 Then 'idem
                    CD.Worksheets.Add After:=Sheets(Sheets.Count) 'idem
                    Set OD = ActiveSheet 'idem
                    OD.Name = "2" 'idem
                End If 'idem
                On Error GoTo 0 'idem
                Set DEST = IIf(OD.Range("B1") = "", OD.Range("B1"), OD.Cells(Application.Rows.Count, "B").End(xlUp).Offset(1, 0)) 'idem
                OS.Cells(I, "B").Resize(1, 66).Copy DEST 'idem
            Case "3" 'idem
                On Error Resume Next 'idem
                Set OD = CD.Worksheets("3") 'idem
                If Err <> 0 Then 'idem
                    CD.Worksheets.Add After:=Sheets(Sheets.Count) 'idem
                    Set OD = ActiveSheet 'idem
                    OD.Name = "3" 'idem
                End If 'idem
                On Error GoTo 0 'idem
                Set DEST = IIf(OD.Range("B1") = "", OD.Range("B1"), OD.Cells(Application.Rows.Count, "B").End(xlUp).Offset(1, 0)) 'idem
                OS.Cells(I, "B").Resize(1, 66).Copy DEST 'idem
            Case "4" 'idem
                On Error Resume Next 'idem
                Set OD = CD.Worksheets("4") 'idem
                If Err <> 0 Then 'idem
                    CD.Worksheets.Add After:=Sheets(Sheets.Count) 'idem
                    Set OD = ActiveSheet 'idem
                    OD.Name = "4" 'idem
                End If 'idem
                On Error GoTo 0 'idem
                Set DEST = IIf(OD.Range("B1") = "", OD.Range("B1"), OD.Cells(Application.Rows.Count, "B").End(xlUp).Offset(1, 0)) 'idem
                OS.Cells(I, "B").Resize(1, 66).Copy DEST 'idem
        End Select 'fin de l'action en en fonction de la valeur de la cellule de la boucle
    Next I 'prochaine ligne de la boucle
    CS.Close False 'Ferme le classeur source sans enregistrer
    F = Dir 'définit le prochain fichier .xlsx ayant CA comme chemin d'accès
Loop 'Boucle sur le fichier .xlsx suivant
Application.ScreenUpdating = True 'Affiche les rafraîchissemetns d'écran
Application.DisplayAlerts = True 'active les messages d'alertes Excel
End Sub

Slt Thauthème,

CA marche parfaitement! Merci beaucoup.

Une dernière petite chose si je peux me permettre. je souhaite automatiser mes critères.

J'ai donc crée une feuille "A_LIRE" sur mon classeur où sera lancée la macro, et j'ai défini mes critères avec des cellules nommées.

Critere_1 = OC.Range("Crit_1").Value 'Défini le critère 1 avec la cellule nommée Crit_1 (fait référence au critère anciennement "1")

Critere_2 = OC.Range("Crit_2").Value 'Défini le critère 2 avec la cellule nommée Crit_2

Etc...

J'ai modifié le code car les feuilles doivent avoir comme nom l’intitulé du critère

CD.Worksheets(Critere_1) et CD.Worksheet.Add blablalblalbla OD.Name = Critere_1

Sauf que les données relatives au Critere_1 sont collées dans mon onglet "A_LIRE" et non dans l'onglet qu'il aurait du me créé car il n'existe pas. L'onglet n'est même pas crée d'ailleurs

Encore un pb de feuille active ? Ou est-ce que je me suis planté dans la syntaxe ?

Le code est dessous si tu peux me dépanner en m'ajoutant le petit plus qui va me débloquer

Sub MAJ_PLANNING()
Dim CD, CS As Workbook 'déclare la variable CD et CS (Classeur Destination et Classeur Source)
Dim OD, OS, OC, ws As Worksheet 'déclare la variable OD (Onglet Destination et Onglet Source)
Dim CA As String 'déclare la variable CA (Chemin d'Accès des fichiers à parcourir)
Dim F As String 'déclare la variable F (Fichier à ouvrir)
Dim I As Integer
Dim DEST_1, DEST_2 As Range 'déclare la variable DEST (cellule de DESTINATION pour les collages)

Application.ScreenUpdating = False 'masque les rafraîchissemetns d'écran
Application.DisplayAlerts = False 'désactive les messages d'alertes Excel

Set CD = ThisWorkbook 'définit le classeur destination CD
Set OC = CD.Worksheets("A_LIRE") 'Définit OC comme l'onglet consigne du classeur CD
CA = "U:\Macro_Antonio\Dossier_data\" 'définit le chemin d'accès CA
F = Dir(CA & "*.xlsx") 'définit le premier fichier F .xlsx ayant CA comme chemin d'accès

For Each ws In Worksheets 'Pour toutes les feuilles du classeur
    If ws.Name <> "A_LIRE" Then ws.Delete 'Si nom différent de "A_LIRE" alors supprimer la feuille
Next 'Boucle sur toutes les feuilles

Critere_1 = OC.Range("Crit_1").Value 'Défini le critère 1 avec la cellule nommée Crit_1
Critere_2 = OC.Range("Crit_2").Value 'Défini le critère 2 avec la cellule nommée Crit_2
Critere_3 = OC.Range("Crit_3").Value 'Défini le critère 3 avec la cellule nommée Crit_3
Critere_4 = OC.Range("Crit_4").Value 'Défini le critère 4 avec la cellule nommée Crit_4

Do While F <> "" 'boucle tant qu'il existe des fichiers
    Set CS = Workbooks.Open(CA & F) 'définit la classeur source CS an l'ouvrant
    Set OS = CS.Worksheets("A_EXTRAIRE") 'définit l'onglet source OS
    'boucle sur toutes les cellules éditées de la colonne A de l'onglet source OS en partant de la 4ème
    CD.Activate 'active le classeur destination CD
    For I = 4 To OS.Cells(Application.Rows.Count, "A").End(xlUp).Row
        Select Case OS.Cells(I, "A") 'agit en fonction de la valeur de la cellule de la boucle
            Case Critere_1 'cas Trouve Critere_1
                On Error Resume Next 'gestion des erreurs (en cas d'erreur passe à la ligne suivante)
                Set OD = CD.Worksheets(Critere_1) 'définit l'onglet destination OD (génère une erreur si cet onglet n'existe pas)
                If Err <> 0 Then 'condition : si une erreur a été générée
                    CD.Worksheets.Add After:=Sheets(Sheets.Count) 'ajoute une onglet vierge en dernière position
                    Set OD = ActiveSheet 'définit l'onglet destination OD
                    OD.Name = Critere_1 'nomme l'ongflet OD avec le Critere_1
                    Set DEST_1 = IIf(OD.Range("C1") = "", OD.Range("C1"), OD.Cells(Application.Rows.Count, "C").End(xlUp).Offset(1, 0))
                    OS.Cells(3, "C").Resize(1, 66).Copy DEST_1 'copie la cellule B de la boucle redimensionnée et la colle dans DEST
                    OD.Range("C2").Select
                    ActiveWindow.FreezePanes = True
                End If 'fin de la condition
                On Error GoTo 0 'annule la gestion des erreurs
                'définit la cellule de destination DEST (B1 si B1 est vide, sinon, la première cellule vide de la colonne B de l'onglet OD)
                Set DEST_2 = IIf(OD.Range("B2") = "", OD.Range("B2"), OD.Cells(Application.Rows.Count, "B").End(xlUp).Offset(1, 0))
                OS.Cells(I, "B").Resize(1, 66).Copy DEST_2 'copie la cellule B de la boucle redimensionnée et la colle dans DEST

Re,

Première erreur dans la déclaration des variables. Du peux déclarer plusieurs variables dans la même ligne mais tu dois en spécifier le type pour chacune d'entre elles. Ça c'est pas bon :

Dim CD, CS As Workbook 'déclare la variable CD et CS (Classeur Destination et Classeur Source)

Ça oui :

Dim CD As Workbook, CS As Workbook 'déclare la variable CD et CS (Classeur Destination et Classeur Source)

Dans le premier cas toutes les variables non spécifiées sont automatiquement de type Variant (très gourmand en mémoire)...

Je regarde la suite...

[Édition]

• Pas compris pourquoi deux destinations différentes (Dest_1 et Dest_2). Une quand l'onglet est créé puis après un décalage d'une colonne. C'est voulu ? Si c'est le cas t'auras un tableau déstructuré !?...

• Un peu galère les plages nommés pour définir 4 malheureux critères... Si tu y tiens, reprend ton code mais n'oublie pas de déclarer les 4 variables de critère...

Le code (non testé car pas de fichier...)

Sub MAJ_PLANNING()
Dim CD As Workbook, CS As Workbook  'déclare les variables CD et CS (Classeur Destination et Classeur Source)
Dim OD As Worksheet, OS As Worksheet, OC As Worksheet, ws As Worksheet 'déclare les variables OD, OS, OC et ws
Dim Criteres(1 To 4) As String 'déclare le tableau de 4 variables, Criteres
Dim CA As String 'déclare la variable CA (Chemin d'Accès des fichiers à parcourir)
Dim F As String 'déclare la variable F (Fichier à ouvrir)
Dim I As Integer 'déclare la variable I (Incrément)
Dim J As Integer 'déclare la variable J (incrément)
Dim DEST As Range 'déclare la variable DEST (cellule de DESTINATION pour les collages)

Application.ScreenUpdating = False 'masque les rafraîchissemetns d'écran
Application.DisplayAlerts = False 'désactive les messages d'alertes Excel

Set CD = ThisWorkbook 'définit le classeur destination CD
Set OC = CD.Worksheets("A_LIRE") 'Définit OC comme l'onglet consigne du classeur CD
For I = 1 To 4 'boucle sur 4 critères
    Criteres(I) = OC.Cells(I, 1) 'définit le critère Criteres(I) de la boucle
Next I 'prochain critère de la boucle
For Each ws In CD.Worksheets 'boucle sur tous les onglets du classeur destination CD
    If ws.Name <> "A_LIRE" Then ws.Delete 'Si nom de l'onglet est différent de "A_LIRE", supprime l'onglet
Next wx 'prochain onglet de la boucle
CA = "U:\Macro_Antonio\Dossier_data\" 'définit le chemin d'accès CA
F = Dir(CA & "*.xlsx") 'définit le premier fichier F .xlsx ayant CA comme chemin d'accès
Do While F <> "" 'exécute tant qu'il existe des fichiers
    Set CS = Workbooks.Open(CA & F) 'définit la classeur source CS en l'ouvrant
    Set OS = CS.Worksheets("A_EXTRAIRE") 'définit l'onglet source OS
    CD.Activate 'active le classeur destination CD
    'boucle 1 : sur toutes les cellules éditées de la colonne A de l'onglet source OS en partant de la 4ème
    For I = 4 To OS.Cells(Application.Rows.Count, "A").End(xlUp).Row
        For J = 1 To 4 'boucle 2 sur les 4 critères
            'condition 1 : si la valeur de la cellule ligne I colonne A de l'onglet source OS de la boucle 1 est égale
            'au critère Criteres(J) de la boucle 2
            If OS.Cells(I, "A").Value = Criteres(J) Then
                On Error Resume Next 'gestion des erreurs (en cas d'erreur passe à la ligne suivante)
                Set OD = CD.Worksheets(Critères(J)) 'définit l'onglet destination OD (génère une erreur si cet onglet n'existe pas)
                If Err <> 0 Then 'condition : si une erreur a été générée
                    CD.Worksheets.Add After:=Sheets(Sheets.Count) 'ajoute une onglet vierge en dernière position
                    Set OD = ActiveSheet 'définit l'onglet destination OD
                    OD.Name = Criteres(J) 'nomme l'onflet OD avec le Criteres(J) de la boucle 2
                    'définit la cellule de destination DEST (B1 si B1 est vide, sinon, la première cellule vide de la colonne B de l'onglet OD)
                    Set DEST = IIf(OD.Range("B2") = "", OD.Range("B2"), OD.Cells(Application.Rows.Count, "B").End(xlUp).Offset(1, 0))
                    OS.Cells(I, "B").Resize(1, 66).Copy DEST 'copie la cellule B de la boucle redimensionnée et la colle dans DEST
                End If 'fin de la condition
                On Error GoTo 0 'annule la gestion des erreurs
                'définit la cellule de destination DEST (B1 si B1 est vide, sinon, la première cellule vide de la colonne B de l'onglet OD)
                Set DEST = IIf(OD.Range("B2") = "", OD.Range("B2"), OD.Cells(Application.Rows.Count, "B").End(xlUp).Offset(1, 0))
                OS.Cells(I, "B").Resize(1, 66).Copy DEST 'copie la cellule B de la boucle redimensionnée et la colle dans DEST
            End If 'fin de la condition
        Next J 'prochain critère de la boucle 2
    Next I 'prochaine ligne de la boucle 1
    F = Dir 'd
    'définit le prochain fichier .xlsx ayant CA comme chemin d'accès
Loop 'boucle de l'exécution
For Each ws In CD.Worksheets 'boucle sur tous les onglets du classeur destination CD
    If Not ws.Name = "A_LIRE" Then 'condition : si le nom de l'onglet n'est pas "A_LIRE"
        ws.Activate 'active l'onglet
        ws.Range("C2").Select 'sélectionne C2
        ActiveWindow.FreezePanes = True 'fige les volets
    End If 'fin de la condition
Next ws 'prochain onglet de la boucle

Application.ScreenUpdating = True 'affiche les rafraîchissemetns d'écran
Application.DisplayAlerts = True 'active les messages d'alertes Excel
End Sub

Salut Thauthème,

Whaou ça marche nikel ! j'ai juste corrigé une petite erreur de syntaxe des For(I) et (J) car tu ne faisais pas référence au bon For à un certain moment de la macro. Normal vu que c'est un peu le bordel avec les For qui s'enchainent et que tu ne puisses pas tester la macro.

En tout cas un énorme merci pour ta patience et le temps consacré !

Pour info j'ai rajouté mon Dest_1 et Dest_2.

Dest_1 me permet de récupérer les intitulés de colonnes sur mes autres classeurs

Dest_2 me permet de récupérer la ligne i que je souhaite copier

Dernière petite chose avant de clôturer le sujet, par curiosité :

OS.Cells(3, "C").Resize(1, 66)

Comment automatiser le 66, pour lui dire la dernière colonne non vide de la ligne ?

Et pareil pour le code

ws.Range("B" & i & ":ZZ1000")

Comment lui dire de B "i" à la dernière ligne non vide de la dernière colonne non vide ?

Merci d'avance

Pour ceux qui suivent,

Ci-dessous le code définitif fonctionnel

Sub Test_5()
Dim CD As Workbook, CS As Workbook  'déclare les variables CD et CS (Classeur Destination et Classeur Source)
Dim OD As Worksheet, OS As Worksheet, OC As Worksheet, ws As Worksheet 'déclare les variables OD, OS, OC et ws
Dim Criteres(14 To 17) As String 'déclare le tableau de 4 variables, Criteres
Dim CA As String 'déclare la variable CA (Chemin d'Accès des fichiers à parcourir)
Dim F As String 'déclare la variable F (Fichier à ouvrir)
Dim I As Integer 'déclare la variable I (Incrément)
Dim J As Integer 'déclare la variable J (incrément)
Dim DEST_1 As Range, DEST_2 As Range 'déclare la variable DEST (cellule de DESTINATION pour les collages)

Application.ScreenUpdating = False 'masque les rafraîchissemetns d'écran
Application.DisplayAlerts = False 'désactive les messages d'alertes Excel

Set CD = ThisWorkbook 'définit le classeur destination CD
Set OC = CD.Worksheets("A_LIRE") 'Définit OC comme l'onglet consigne du classeur CD
For J = 14 To 17 'boucle sur 4 critères
    Criteres(J) = OC.Cells(J, 5) 'définit le critère Criteres(I) de la boucle

Next J 'prochain critère de la boucle

For Each ws In CD.Worksheets 'boucle sur tous les onglets du classeur destination CD
    If ws.Name <> "A_LIRE" Then ws.Delete 'Si nom de l'onglet est différent de "A_LIRE", supprime l'onglet
Next ws 'prochain onglet de la boucle

CA = "U:\Macro_Antonio\Dossier_data\" 'définit le chemin d'accès CA
F = Dir(CA & "*.xlsx") 'définit le premier fichier F .xlsx ayant CA comme chemin d'accès
Do While F <> "" 'exécute tant qu'il existe des fichiers
    Set CS = Workbooks.Open(CA & F) 'définit la classeur source CS en l'ouvrant
    Set OS = CS.Worksheets("A_EXTRAIRE") 'définit l'onglet source OS
    CD.Activate 'active le classeur destination CD
    'boucle 1 : sur toutes les cellules éditées de la colonne A de l'onglet source OS en partant de la 4ème
    For I = 4 To OS.Cells(Application.Rows.Count, "A").End(xlUp).Row
        For J = 14 To 17 'boucle 2 sur les 4 critères
            'condition 1 : si la valeur de la cellule ligne I colonne A de l'onglet source OS de la boucle 1 est égale
            'au critère Criteres(J) de la boucle 2
            If OS.Cells(I, "A").Value = Criteres(J) Then
                On Error Resume Next 'gestion des erreurs (en cas d'erreur passe à la ligne suivante)
                Set OD = CD.Worksheets(Criteres(J)) 'définit l'onglet destination OD (génère une erreur si cet onglet n'existe pas)
                If Err <> 0 Then 'condition : si une erreur a été générée
                    CD.Worksheets.Add After:=Sheets(Sheets.Count) 'ajoute une onglet vierge en dernière position
                    Set OD = ActiveSheet 'définit l'onglet destination OD
                    OD.Name = Criteres(J) 'nomme l'onflet OD avec le Criteres(J) de la boucle 2
                    'définit la cellule de destination DEST (B1 si B1 est vide, sinon, la première cellule vide de la colonne B de l'onglet OD)
                    Set DEST_1 = IIf(OD.Range("C1") = "", OD.Range("C1"), OD.Cells(Application.Rows.Count, "C").End(xlUp).Offset(1, 0))
                    OS.Cells(3, "C").Resize(1, 66).Copy DEST_1 'copie la cellule B de la boucle redimensionnée et la colle dans DEST
                End If 'fin de la condition
                On Error GoTo 0 'annule la gestion des erreurs
                'définit la cellule de destination DEST (B1 si B1 est vide, sinon, la première cellule vide de la colonne B de l'onglet OD)
                Set DEST_2 = IIf(OD.Range("B2") = "", OD.Range("B2"), OD.Cells(Application.Rows.Count, "B").End(xlUp).Offset(1, 0))
                OS.Cells(I, "B").Resize(1, 66).Copy DEST_2 'copie la cellule B de la boucle redimensionnée et la colle dans DEST
            End If 'fin de la condition
        Next J 'prochain critère de la boucle 2
    Next I 'prochaine ligne de la boucle 1
    CS.Close False
    F = Dir 'd
    'définit le prochain fichier .xlsx ayant CA comme chemin d'accès
Loop 'boucle de l'exécution

For Each ws In CD.Worksheets 'boucle sur tous les onglets du classeur destination CD
    If Not ws.Name = "A_LIRE" Then 'condition : si le nom de l'onglet n'est pas "A_LIRE"
        ws.Activate 'active l'onglet
        ws.Range("C2").Select 'sélectionne C2
        ActiveWindow.FreezePanes = True 'fige les volets
        ActiveWindow.Zoom = 90 'Réduit le zoom à 90%
        ws.Range("B:B,X:X,AT:AT").EntireColumn.AutoFit 'Ajuste automatiquement les colonnes citées
        ws.Range("C:W,Y:AS,AU:BO").ColumnWidth = 5.5

    End If 'fin de la condition
Next ws 'prochain onglet de la boucle

Application.ScreenUpdating = True 'affiche les rafraîchissemetns d'écran
Application.DisplayAlerts = True 'active les messages d'alertes Excel
End Sub

Re,

• J'ai (enfin) compris pour les deux variables DEST !...

• Pour définir la dernière ligne et la dernière colonne éditée d'une plage il y a beaucoup de possibilité plus ou moins adaptée à la configuration de la plage. Aussi, pour cette question, je ne pourrai répondre qu'avec un exemple de la plage...

• Le code modifié pour la dernière colonne :

Sub Test_5()
Dim CD As Workbook, CS As Workbook  'déclare les variables CD et CS (Classeur Destination et Classeur Source)
Dim OD As Worksheet, OS As Worksheet, OC As Worksheet, ws As Worksheet 'déclare les variables OD, OS, OC et ws
Dim Criteres(14 To 17) As String 'déclare le tableau de 4 variables, Criteres
Dim CA As String 'déclare la variable CA (Chemin d'Accès des fichiers à parcourir)
Dim F As String 'déclare la variable F (Fichier à ouvrir)
Dim I As Integer 'déclare la variable I (Incrément)
Dim J As Integer 'déclare la variable J (incrément)
Dim DEST_1 As Range, DEST_2 As Range 'déclare la variable DEST (cellule de DESTINATION pour les collages)
Dim DC As Integer 'déclare la variable DC (Derniere Colonne)
Application.ScreenUpdating = False 'masque les rafraîchissemetns d'écran
Application.DisplayAlerts = False 'désactive les messages d'alertes Excel

Set CD = ThisWorkbook 'définit le classeur destination CD
Set OC = CD.Worksheets("A_LIRE") 'Définit OC comme l'onglet consigne du classeur CD
For J = 14 To 17 'boucle sur 4 critères
    Criteres(J) = OC.Cells(J, 5) 'définit le critère Criteres(I) de la boucle
Next J 'prochain critère de la boucle
For Each ws In CD.Worksheets 'boucle sur tous les onglets du classeur destination CD
    If ws.Name <> "A_LIRE" Then ws.Delete 'Si nom de l'onglet est différent de "A_LIRE", supprime l'onglet
Next ws 'prochain onglet de la boucle

CA = "U:\Macro_Antonio\Dossier_data\" 'définit le chemin d'accès CA
F = Dir(CA & "*.xlsx") 'définit le premier fichier F .xlsx ayant CA comme chemin d'accès
Do While F <> "" 'exécute tant qu'il existe des fichiers
    Set CS = Workbooks.Open(CA & F) 'définit la classeur source CS en l'ouvrant
    Set OS = CS.Worksheets("A_EXTRAIRE") 'définit l'onglet source OS
    DC = OS.Cells(3, Application.Columns.Count).End(xlToLeft).Column
    CD.Activate 'active le classeur destination CD
    'boucle 1 : sur toutes les cellules éditées de la colonne A de l'onglet source OS en partant de la 4ème
    For I = 4 To OS.Cells(Application.Rows.Count, "A").End(xlUp).Row
        For J = 14 To 17 'boucle 2 sur les 4 critères
            'condition 1 : si la valeur de la cellule ligne I colonne A de l'onglet source OS de la boucle 1 est égale
            'au critère Criteres(J) de la boucle 2
            If OS.Cells(I, "A").Value = Criteres(J) Then
                On Error Resume Next 'gestion des erreurs (en cas d'erreur passe à la ligne suivante)
                Set OD = CD.Worksheets(Criteres(J)) 'définit l'onglet destination OD (génère une erreur si cet onglet n'existe pas)
                If Err <> 0 Then 'condition : si une erreur a été générée
                    CD.Worksheets.Add After:=Sheets(Sheets.Count) 'ajoute une onglet vierge en dernière position
                    Set OD = ActiveSheet 'définit l'onglet destination OD
                    OD.Name = Criteres(J) 'nomme l'onflet OD avec le Criteres(J) de la boucle 2
                    'définit la cellule de destination DEST (B1 si B1 est vide, sinon, la première cellule vide de la colonne B de l'onglet OD)
                    Set DEST_1 = IIf(OD.Range("C1") = "", OD.Range("C1"), OD.Cells(Application.Rows.Count, "C").End(xlUp).Offset(1, 0))
                    OS.Cells(3, "C").Resize(1, DC - 2).Copy DEST_1 'copie la cellule B de la boucle redimensionnée et la colle dans DEST
                End If 'fin de la condition
                On Error GoTo 0 'annule la gestion des erreurs
                'définit la cellule de destination DEST (B1 si B1 est vide, sinon, la première cellule vide de la colonne B de l'onglet OD)
                Set DEST_2 = IIf(OD.Range("B2") = "", OD.Range("B2"), OD.Cells(Application.Rows.Count, "B").End(xlUp).Offset(1, 0))
                OS.Cells(I, "B").Resize(1, DC - 1).Copy DEST_2 'copie la cellule B de la boucle redimensionnée et la colle dans DEST
            End If 'fin de la condition
        Next J 'prochain critère de la boucle 2
    Next I 'prochaine ligne de la boucle 1
    CS.Close False
    F = Dir 'd
    'définit le prochain fichier .xlsx ayant CA comme chemin d'accès
Loop 'boucle de l'exécution

For Each ws In CD.Worksheets 'boucle sur tous les onglets du classeur destination CD
    If Not ws.Name = "A_LIRE" Then 'condition : si le nom de l'onglet n'est pas "A_LIRE"
        ws.Activate 'active l'onglet
        ws.Range("C2").Select 'sélectionne C2
        ActiveWindow.FreezePanes = True 'fige les volets
        ActiveWindow.Zoom = 90 'Réduit le zoom à 90%
        ws.Range("B:B,X:X,AT:AT").EntireColumn.AutoFit 'Ajuste automatiquement les colonnes citées
        ws.Range("C:W,Y:AS,AU:BO").ColumnWidth = 5.5
    End If 'fin de la condition
Next ws 'prochain onglet de la boucle

Application.ScreenUpdating = True 'affiche les rafraîchissemetns d'écran
Application.DisplayAlerts = True 'active les messages d'alertes Excel
End Sub

Re,

Je n'ai pas encore testé mais je ne doute pas de son bon fonctionnement

Un énooorme merci à toi ! Ça fait plaisir d'être aidé par des gens aussi compétent

@ + !