Copier/coller le nom d'un onglet VBA

[Nonno]

Bonjour,

Je voudrais copier un onglet d'un fichier pour le coller dans un autre tout en copiant également le nom de l'onglet. Je ne trouve pas le code pour copier/coller le nom de l'onglet pouvez vous m'aider ?
Voici mon code :

 Workbooks.Open (Chemin & "\" & DossierDB & "\" & FichierDB), UpdateLinks:=False
        Workbooks(FichierDB).Activate
        Cells.Select
        Selection.Copy
        Windows(FichierMacro).Activate
        ActiveWindow.ScrollWorkbookTabs Position:=xlLast
        Sheets.Add After:=Sheets(Sheets.Count)
        ActiveSheet.Paste
        ActiveWindow.DisplayGridlines = False
        ActiveWindow.Zoom = 85
        Application.CutCopyMode = False
        Workbooks(FichierDB).Activate
        [B]ActiveSheet.Name.Copy[/B]
        Windows(FichierMacro).Activate
        [B]ActiveSheet.Name.Paste[/B]

Ca bloque pour la partie en gras...

Merci d'avance,

Nono

 

[Nonno]

Re : Copier/coller le nom d'un onglet VBA

Ah d'accord merci !
En fait mon fichier cible change tout le temps car dans ma macro j'ai un code qui indique où aller chercher mon fichier cible qui se trouve dans un dossier. Au départ ma macro marche comme ca :
J'ai un fichier excel avec un onglet qui contient ma macro et d'autres onglets.
Lorsque j’exécute ma macro : il va chercher dans un dossier et ouvrir chaque fichier excel et copier coller dans chaque onglet correspondant dans mon fichier source.

Dans mon code j'essaie d'introduire ta macro mais je bloque au Wbs...
Voici mon code :

 Sub Bouton1_Cliquer()
    Dim FichierMacro As String
    Dim Chemin As String
    Dim DossierDB As String
    Dim FichierDB As String
    Dim NomOnglet As String
    Dim WBc, WBs, sh

    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")
    Set WBc = ThisWorkbook
    Set WBs = Workbooks("FichierDB")
    
    For Each sh In WBc.Sheets
    If sh.Name = WBs.ActiveSheet.Name Then
        
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
            
            Else
        Workbooks.Open (Chemin & "\" & DossierDB & "\" & FichierDB), UpdateLinks:=False
        Workbooks(FichierDB).Activate
        Cells.Select
        Selection.Copy
        Windows(FichierMacro).Activate
        ActiveWindow.ScrollWorkbookTabs Position:=xlLast
        Sheets.Add After:=Sheets(Sheets.Count)
        ActiveSheet.Paste
        ActiveWindow.DisplayGridlines = False
        ActiveWindow.Zoom = 85
        Application.CutCopyMode = False
        With Workbooks(FichierDB).ActiveSheet
        NomOnglet = .Name
        Windows(FichierMacro).Activate
        ActiveSheet.Name = NomOnglet
        End With
        End If
        Next
        End If
        

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

    Application.ScreenUpdating = True
    Application.DisplayAlerts = True

    MsgBox ("La compilation est terminée")

End Sub

Merci
Cdt