Macro qui crée un onglet automatiquement à partir d'un fichier

Nonno

XLDnaute Nouveau
Bonjour,

Je ne sais pas si je vais réussir à me faire comprendre mais je tente quand même...

J'ai un dossier nommé "SX" contenant plusieurs fichiers excel, la structure des fichiers est identiques, seuls les chiffres changent.
J'ai un fichier excel nommé consolidation qui contient un onglet macro, cette macro vient ouvrir mon dossier "SX" et ouvre chaque feuille du dossier pour copier coller les nouvelles données dans mon fichier de consolidation dans l'onglet qui leur correspond. Il y a autant d'onglet que de fichiers excel de consolidation que dans mon dossier SX.
Du coup, dans l'ordre mon fichier de consolidation se présente ainsi :
Macro/Global/Feuille 1/ Feuille 2/...
L'onglet Global reprend les données des autres onglets.

Je voudrais rajouter une boucle à ma macro pour que lorsqu'un nouveau fichier excel apparaît dans le dossier "SX", il crée automatiquement un onglet dans mon fichier de consolidation en copiant la feuille du nouveau fichier et en lui attribuant son nom d'onglet.

Voici mon code de la macro :

Code:
 Sub Bouton1_Cliquer()
    Dim FichierMacro As String
    Dim Chemin As String
    Dim DossierDB As String
    Dim FichierDB As String

    FichierMacro = ActiveWorkbook.Name
    Chemin = ActiveWorkbook.Path

    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    
    DossierDB = Sheets("Macro").Range("A2")
    If DossierDB <> "" Then
        FichierDB = Dir(Chemin & "\" & DossierDB & "\SX*.xls")
        Do Until FichierDB = ""
            Workbooks.Open (Chemin & "\" & DossierDB & "\" & FichierDB), UpdateLinks:=False

            Windows(FichierMacro).Activate
            Sheets(Left(FichierDB, Len(FichierDB) - 4)).Select
            Rows("7:7").Select
            Range(Selection, Selection.End(xlDown)).ClearContents
            
            Workbooks(FichierDB).Activate
            Rows("7:1000").Select
            Selection.Copy
            Windows(FichierMacro).Activate
            ActiveSheet.Paste

            Workbooks(FichierDB).Activate
            ActiveWorkbook.Close True
            Application.Wait (Now + TimeValue("00:00:01"))
            FichierDB = Dir
        Loop
    End If

    Sheets("Macro").Select
    ActiveCell.Offset(1, 0).Select

    Application.ScreenUpdating = True
    Application.DisplayAlerts = True

    MsgBox ("La compilation est terminée")

End Sub

D'avance, un grand merci pour votre aide.

Nono
 

Discussions similaires

  • Question
Microsoft 365 Code VBA
Réponses
10
Affichages
704

Statistiques des forums

Discussions
314 644
Messages
2 111 528
Membres
111 189
dernier inscrit
Laurent.