Macro pour copier onglet dans un seul fichier

Bonjour à tous

Je cherche à créer une macro me permettant de déplacer automatiquement des onglets depuis plusieurs fichiers excel dans un seul et même fichier

Pour être plus précis :

• J’ai X fichiers tous présents dans un seul et même dossier
• Chacun de ces fichiers comporte un onglet appelé « BT-XXX Follow-up » - avec XXX pour des noms de domaines différents
• Je souhaite créer un fichier reprenant chacun de ces onglets et enregistrer le fichier sur le même répertoire réseau (avec si possible pour nom de fichier output : Analyse 2017)

J’ai parcouru le forum ainsi que l’internet  et je n’ai pas trouvé de solution satisfaisante à 100%

Auriez vous une idée de code ?

Merci par avance

Très bonne journée

Bonjour,

Voilà une proposition, dis nous si cela te convient !

Sub ListingFichiers()
Dim Rep As String, Fichier As String

Rep = Workbooks(ActiveWorkbook.Name).Path & "\"
Fichier = Dir(Rep)
Do While Fichier <> ""
MsgBox Fichier
    If Fichier <> ThisWorkbook.Name Then
        On Error Resume Next
        Workbooks(Fichier).Activate
        If Err <> 0 Then
        Workbooks.Open Filename:=Rep & Fichier
        On Error GoTo 0
        End If
        For Each ws In ActiveWorkbook.Sheets
            If ws.Name Like "BT-*" Then
                ws.Copy After:=Workbooks("Analyse 2017.xlsm").Sheets(1)
            End If
        Next ws
        Application.DisplayAlerts = False
        Workbooks(Fichier).Close False
        Application.DisplayAlerts = True
        Fichier = Dir
        Else
        Fichier = Dir
    End If
Loop
End Sub

Macro à lancer depuis ton fichier "Analyse 2017" !

a plus !

Merci pour le code

Il a l'air de bien fonctionner

Cependant j'ai une erreur en fin de process, Excel ne veut pas enregistrer le fichier, il dit qu'il comporte des erreurs...

Est ce que les onglets sont copiés / collés en valeur sans lien avec les fichiers source?

Par ailleurs, est il possible d'enlever le popup demandant de cliquer sur OK dès qu'un des fichiers source est ouvert?

Merci encore, cela m'enlève une bonne épine du pied

Bonjour,

Pour le message à chaque ouverture, il faut enlever le

MsgBox Fichier

dans la macro.

Les feuilles sont copiées avec les formules et les liens entre les fichiers, il est possible de les mettre en valeur à la fin de la macro !

Si tu as des messages de mise à jour, tu peux mettre en début de code en dessous du Sub()

application.displayalerts=false

A plus

Merci pour ta réponse

Je viens de modifier le code mais j'ai toujours le problème, je ne peux pas enregistrer le fichier, Excel me dit "Document non enregistré".

Même si je fais un "enregistrer sous" pour enregistrer le fichier sous un autre nom, cela ne fonctionne pas.

Savez vous à quoi cela est du?

Mille merci pour votre aide

Bonne journée

Ton fichier est-il déjà enregistré dans le dossier de tes fichiers ?

une fois la macro terminée, tu ne peux plus enregistrer ?

Tu peux essayer de coller ce code dans le module "ThisWorkbook"

Private Sub Workbook_BeforeClose(Cancel As Boolean)
Me.Save
End Sub

Hello

merci pour ta réponse

Quand tu dis dans "le module "ThisWorkbook"", qu'entends tu par cela?

Merci

Quand tu ouvres VBA avec Alt+F11, sur la gauche, il y a la liste de tes feuilles dont "ThisWorkbook", tu doubles cliques et tu colles le code que j'ai mis.

Hello

C'est bon j'ai copié le code

Mais j'ai toujours la même erreur à savoir:

<?xml version="1.0" encoding="UTF-8" standalone="true"?>

-<recoveryLog xmlns="http://schemas.openxmlformats.org/spreadsheetml/2006/main">

<logFileName>error096440_01.xml</logFileName>

<summary>Des erreurs ont été détectées dans le fichier « C:\Users\xxx\Desktop\Nouveau dossier\Analyse 2017.xlsm »</summary>

-<additionalInfo>

<info>Le fichier était trop endommagé pour pouvoir être réparé. Excel a essayé d'enregistrer vos formules et valeurs, mais certaines données ont peut-être été perdues ou endommagées.</info>

</additionalInfo>

</recoveryLog>

Savez vous 'où cela peut venir?

Est ce que le fait de copier / coller en valeur pourrait résoudre le problème?

Peux-tu nous envoyer le fichier depuis lequel tu lances la macro stp ?

Merci

yes, le voici

Alors là je sèche, chez moi aucun soucis !

Y-a-t'il des particularités sur les feuilles copiées ? formes, images, contrôle de formulaire ou encore liste de noms utilisés dans certaines formules ? Je ne sais pas.

tu peux essayer de faire tourner cette macro pour coller toutes les cellules en valeurs et essayer de sauvegarder sinon après ça, je ne saurai pas quoi faire d'autres.

Sub Macro1()

For Each wksh In ThisWorkbook.Worksheets
    Cells.Copy
    Selection.PasteSpecial Paste:=xlPasteValues
    Application.CutCopyMode = False
Next wksh

End Sub

Merci pour ta réponse

J'ai inséré le code pour le copier / coller en valeur. Cela n'a pas marché car j'ai quelques cellules fusionnées

Est il possible de forcer ce copier / coller (quitte à ne pas reprendre la cellule fusionnée).

Je pense qu'une fois le copier coller en valeur fonctionnera, je n'aurai plus de soucis de sauvegarde...

Autant pour moi,

j'ai copier la mauvaise macro désolé

Voilà, celle-ci fonctionne chez moi même avec des cellules fusionnées !

Sub CopieVal()

For Each wksh In ThisWorkbook.Worksheets
    wksh.Cells.Copy
    wksh.Range("A1").PasteSpecial Paste:=xlPasteValues
    Application.CutCopyMode = False
Next wksh

End Sub

A plus !

Et bien voilà, c'est parfait, cela fonctionne !!!!

Mille merci, vous êtes vraiment des pros

Bonjour à tous

Je rouvre ce post car j'ai un petit souci avec la macro créée

Pour rappel depuis, voici le code à date:

Sub ListingFichiers()
Application.DisplayAlerts = False
Dim Rep As String, Fichier As String

Rep = Workbooks(ActiveWorkbook.Name).Path & "\"
Fichier = Dir(Rep)
Do While Fichier <> ""
    If Fichier <> ThisWorkbook.Name Then
        On Error Resume Next
        Workbooks(Fichier).Activate
        If Err <> 0 Then
        Workbooks.Open Filename:=Rep & Fichier
        On Error GoTo 0
        End If
        For Each ws In ActiveWorkbook.Sheets
            If ws.Name Like "BT*" Then
                ws.Copy After:=Workbooks("BT - Synthesis by domain.xlsm").Sheets(1)
            End If
        Next ws
        Application.DisplayAlerts = False
        Workbooks(Fichier).Close False
        Application.DisplayAlerts = True
        Fichier = Dir
        Else
        Fichier = Dir
    End If
Loop

For Each wksh In ThisWorkbook.Worksheets
    wksh.Cells.Copy
    wksh.Range("A1").PasteSpecial Paste:=xlPasteValues
    Application.CutCopyMode = False
Next wksh

End Sub

En fait, j'aimerai, lorsque je lance la macro (c'est à dire une fois par mois), remplacer le contenu des feuilles déjà copiées (celles commençant par BT*) sans changer le nom de la feuille en question -> Juste remplacer les cellules (car actuellement quand je lance la macro, cela duplique les feuilles avec un "(2)" après le nom des nouveaux onglets copiés

N'hésitez pas à me dire si ma demande n'est pas claire...

Mille merci

Bonne journée

Bonjour,

voilà quand tu lances la macro, elle teste si le nom de feuille existe déjà si c'est le cas, elle colle les données de la feuille dans la feuille portant le même nom sinon elle colle la feuille entière.

A remplacer par la macro actuelle :

Sub ListingFichiers()
Application.DisplayAlerts = False
Dim Rep As String, Fichier As String

Rep = Workbooks(ActiveWorkbook.Name).Path & "\"
Fichier = Dir(Rep)
Do While Fichier <> ""
    If Fichier <> ThisWorkbook.Name Then
        On Error Resume Next
        Workbooks(Fichier).Activate
        If Err <> 0 Then
        Workbooks.Open Filename:=Rep & Fichier
        On Error GoTo 0
        End If
        For Each ws In ActiveWorkbook.Sheets
            If ws.Name Like "BT*" Then
                For Each wk In Workbooks("Analyse 2017.xlsm").Sheets
                i = 1 + i
                    If ws.Name = wk.Name Then
                        ws.Cells.Copy
                        wk.[A1].PasteSpecial
                        Else
                    If i = Workbooks("Analyse 2017.xlsm").Sheets.Count Then
                            ws.Copy After:=Workbooks("Analyse 2017.xlsm").Sheets(1)
                    End If
                    End If
                Next wk
            End If
        Next ws
        Application.DisplayAlerts = False
        Workbooks(Fichier).Close False
        Application.DisplayAlerts = True
        Fichier = Dir
        Else
        Fichier = Dir
    End If
Loop
End Sub

A plus

ouaou !

Ca marche

merci beaucoup c'est tellement cool !

bonne journée

Hello

Sur le code dernièrement fourni, j'ai rajouté le copié collé en valeur, à la toute fin de la macro.

Sauf que ce copier / coller s'applique à toutes les feuilles mais je souhaiterai qu'il s'applique uniquement aux feuilles récemment rappatriées (celles commençant par BT*)

J'ai essayé de modifier mais cela ne fonctionne pas...

voici le code à date :

Sub ListingFichiers()
Application.DisplayAlerts = False
Dim Rep As String, Fichier As String

Rep = Workbooks(ActiveWorkbook.Name).Path & "\"
Fichier = Dir(Rep)
Do While Fichier <> ""
    If Fichier <> ThisWorkbook.Name Then
        On Error Resume Next
        Workbooks(Fichier).Activate
        If Err <> 0 Then
        Workbooks.Open Filename:=Rep & Fichier
        On Error GoTo 0
        End If
        For Each ws In ActiveWorkbook.Sheets
            If ws.Name Like "BT*" Then
                For Each wk In Workbooks("BT - Synthesis by domain.xlsm").Sheets
                i = 1 + i
                    If ws.Name = wk.Name Then
                        ws.Cells.Copy
                        wk.[A1].PasteSpecial
                        Else
                    If i = Workbooks("BT - Synthesis by domain.xlsm").Sheets.Count Then
                            ws.Copy After:=Workbooks("BT - Synthesis by domain.xlsm").Sheets(1)
                    End If
                    End If
                Next wk
            End If
        Next ws
        Application.DisplayAlerts = False
        Workbooks(Fichier).Close False
        Application.DisplayAlerts = True
        Fichier = Dir
        Else
        Fichier = Dir
    End If
Loop

For Each wksh In ThisWorkbook.Worksheets
    wksh.Cells.Copy
    wksh.Range("A1").PasteSpecial Paste:=xlPasteValues
    Application.CutCopyMode = False
Next wksh

End Sub

Avec la dernière partie qui copie colle en valeur :

For Each wksh In ThisWorkbook.Worksheets
If wksh.name is like "BT*" then
    wksh.Cells.Copy
    wksh.Range("A1").PasteSpecial Paste:=xlPasteValues
    Application.CutCopyMode = False
End if
Next wksh

A plus !