Fermeture de mon dossier apres avoir ouvert d'autre tableur Excel

Bonjour à tous,

Pour faire simple, j'ai plusieurs fichiers excel de donées dans un dossier ainsi qu'un fichiers qui veut toutes les regrouper. dans mon fichiers excel global, j'ai une macro qui me permet d'ouvrir un fichier excel, de copier une cellule, de la coller dans mon premier fichiers et de refermer l'excel dans lequel j'ai pris ma donnée. Je fais ça pour tous les excel de données qui sont dans le même dossier que l'excel global. Pour ça, il n'y a pas de problème, tout fonctionne.

Mon problème est que lorsque je dois refermer le fichier de données, il ferme aussi, après avoir ouvert tout les dossiers, mon fichiers global alors que je ne veux pas.
Pour moi, le problème vient du fait que je demande d'ouvrir tout les fichiers .xls (fichier de données sont des .xls) et donc qu'il m'ouvre à la fin mon fichiers global en .xlsm.

Je ne sais pas comment l'empêcher de fermer mon dossier global.

Si vous pouviez m'aider, j'en serait très reconnaissant. Merci d'avance

Sub Macro1()
Dim CD As Workbook 'déclare la variable CD (Claseur 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 (Fichiers)
Dim CS As Workbook 'déclare la variable CS (Claseur Source)
Dim OS As Worksheet 'déclare la variable OS (Onglet Source)
Dim i As Long
Dim DEST As Range 'déclare la variable DEST (cellule de DESTination)
Dim name As Object

i = 1

Application.ScreenUpdating = False 'masque les rafraîchissements d'écran
Set CD = ThisWorkbook 'définit le classeur destination CD
Set OD = CD.Sheets("Feuil1") 'définit l'onglet destination OD

CA = CD.Path & "\" 'définit le chemin d'accès CA
OD.Range("A1:AH" & Application.Rows.Count).Clear 'supprime d'éventuelles ancienne données dans l'onglet OD
F = Dir(CA & "*.xls") 'définit le premier fichier F avec l'extension ".xls" dans le dossier CA

Call ViderPressePapier

Do While F <> "" 'exécute tant qu'il existe des fichiers F

    Set CS = Workbooks.Open(CA & F)
    Set CS = ActiveWorkbook 'définit le classeur source CS
    Set OS = CS.Sheets("Feuil1") 'définit l'onglet source OS
    'définit la cellule de destination DEST (A1, si A1 est vide, sinon, la première cellule vide de la ligne 1 de l'onglet OD)
    Set DEST = IIf(OD.Cells(1, i).Value = "", OD.Cells(1, i), OD.Cells(Application.Rows.Count, "A").End(xlUp).Offset(1, 0))

    OS.Range("AB23").Copy 'copie la plage voulu...(DL)
    DEST.PasteSpecial (xlPasteValuesAndNumberFormats) 'renvoie dans DEST les valeurs et les formats de nombre de la plage copiée
    DEST.Offset(0, 33).Value = OS.Range("a1").Value 'récupère le nom de 'longlet source
    CS.Close SaveChanges = False 'ferme le fichier source sans enregister les changements

    i = i + 1

    F = Dir 'fichier suivant commençant par DM avec l'extension ".xls" dans le dossier CA
    Call ViderPressePapier

Loop 'boucle

OD.Range("A1").Select 'sélectionne la cellule A3 de l'onglet OD
CD.Save 'enregistre le fichier destination
Application.ScreenUpdating = True 'affiche les rafraîchissements d'écran

End Sub

Bonjour,

A mon avis, vous sélectionnez à tort votre fichier global. Essayer peut être ceci

    Do While F <> "" 'exécute tant qu'il existe des fichiers F

        If F <> CD.Name Then
            Set CS = Workbooks.Open(CA & F) 'définit le classeur source CS
            'Set CS = ActiveWorkbook  instruction inutile car l'objet CS est défini par l'instruction précédente

            Set OS = CS.Sheets("Feuil1") 'définit l'onglet source OS
            'définit la cellule de destination DEST (A1, si A1 est vide, sinon, la première cellule vide de la ligne 1 de l'onglet OD)
            Set DEST = IIf(OD.Cells(1, i).Value = "", OD.Cells(1, i), OD.Cells(Application.Rows.Count, "A").End(xlUp).Offset(1, 0))

            OS.Range("AB23").Copy 'copie la plage voulu...(DL)
            DEST.PasteSpecial (xlPasteValuesAndNumberFormats) 'renvoie dans DEST les valeurs et les formats de nombre de la plage copiée
            DEST.Offset(0, 33).Value = OS.Range("a1").Value 'récupère le nom de 'longlet source
            CS.Close SaveChanges = False 'ferme le fichier source sans enregister les changements

            i = i + 1
        End If

        F = Dir 'fichier suivant commençant par DM avec l'extension ".xls" dans le dossier CA
        Call ViderPressePapier

    Loop 'boucle

Bonjour,

Pas très joli mais en ajoutant un test sur le nom du classeur ça évite l'execution de la macro sur ThisWorkbook :

Sub Macro1()
Dim CD As Workbook 'déclare la variable CD (Claseur 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 (Fichiers)
Dim CS As Workbook 'déclare la variable CS (Claseur Source)
Dim OS As Worksheet 'déclare la variable OS (Onglet Source)
Dim i As Long
Dim DEST As Range 'déclare la variable DEST (cellule de DESTination)
Dim name As Object

i = 1

Application.ScreenUpdating = False 'masque les rafraîchissements d'écran
Set CD = ThisWorkbook 'définit le classeur destination CD
Set OD = CD.Sheets("Feuil1") 'définit l'onglet destination OD

CA = CD.Path & "\" 'définit le chemin d'accès CA
OD.Range("A1:AH" & Application.Rows.Count).Clear 'supprime d'éventuelles ancienne données dans l'onglet OD
F = Dir(CA & "*.xls") 'définit le premier fichier F avec l'extension ".xls" dans le dossier CA

Do While F <> "" 'exécute tant qu'il existe des fichiers F
    If F <> CD.name Then
        Set CS = Workbooks.Open(CA & F)
        Set CS = ActiveWorkbook 'définit le classeur source CS
        Set OS = CS.Sheets("Feuil1") 'définit l'onglet source OS
        'définit la cellule de destination DEST (A1, si A1 est vide, sinon, la première cellule vide de la ligne 1 de l'onglet OD)
        Set DEST = IIf(OD.Cells(1, i).Value = "", OD.Cells(1, i), OD.Cells(Application.Rows.Count, "A").End(xlUp).Offset(1, 0))

        OS.Range("AB23").Copy 'copie la plage voulu...(DL)
        DEST.PasteSpecial (xlPasteValuesAndNumberFormats) 'renvoie dans DEST les valeurs et les formats de nombre de la plage copiée
        DEST.Offset(0, 33).Value = OS.Range("a1").Value 'récupère le nom de 'longlet source
        CS.Close False 'ferme le fichier source sans enregister les changements
        End If
        i = i + 1

        F = Dir 'fichier suivant commençant par DM avec l'extension ".xls" dans le dossier CA
Loop 'boucle

OD.Range("A1").Select 'sélectionne la cellule A3 de l'onglet OD
CD.Save 'enregistre le fichier destination
Application.ScreenUpdating = True 'affiche les rafraîchissements d'écran

End Sub

Cdlt,

Edit : Oups même idée que toi Thev au même moment le temps que je fasse mes tests.

Merci à vous deux, ça marche parfaitement.