Création d'onglets automatique avec copie d'information

Bonjour à tous,

Je recherche un code VBA me permettant de créer automatiquement des onglets avec le nom des salariés (sans doublons) d'un export.

Et sur chaque onglet créer, il me faudrait les lignes d'informations concernant les salariés.

Je laisse un fichier exemple pour plus de clarté.

Merci d'avance de votre aide et de vos conseils.

Cordialement

Bonjour,

Un essai, avec l'utilisation du filtre élaboré en VBA

Bonne soirée

Bonjour le fil et e forum,

je propose quand même une solution similaire:

Private Sub CommandButton1_Click()
    'https://forum.excel-pratique.com/excel/creation-d-onglets-automatique-avec-copie-d-information-160036

    Dim SalariesDict As Object, Salaries As Variant, i As Long, Salarie As Variant
    Dim ws          As Worksheet
    Set SalariesDict = CreateObject("Scripting.Dictionary")

    With Application
        .ScreenUpdating = False
        .DisplayAlerts = False
    End With

    For Each ws In ThisWorkbook.Worksheets
        If ws.Name <> ThisWorkbook.ActiveSheet.Name Then
            ws.Delete
        End If
    Next ws

    With ActiveSheet
        If Not .AutoFilterMode Then .UsedRange.AutoFilter

        Salaries = Range(.Range("C2"), .Cells(Rows.Count, "C").End(xlUp))
        For i = 1 To UBound(Salaries, 1)
            SalariesDict(Salaries(i, 1)) = 1
        Next

        For Each Salarie In SalariesDict.keys

            .UsedRange.AutoFilter Field:=3, Criteria1:=Salarie
            Sheets.Add(, Sheets(Sheets.Count)).Name = Salarie

            With .UsedRange.SpecialCells(xlCellTypeVisible)
                .Copy Sheets(Sheets.Count).Range("A1")
                .Copy
            End With

            With Sheets(Sheets.Count).Range("A1")
                .PasteSpecial xlPasteColumnWidths
                .PasteSpecial xlPasteAll
            End With

        Next

        On Error Resume Next
        .ShowAllData
        On Error GoTo 0

    End With

    Sheets("Export").Activate

    ActiveWorkbook.Save

    With Application
        .DisplayAlerts = True
        .ScreenUpdating = True
    End With

End Sub

Cordialement

Bonjour,

Super ça fonctionne merci beaucoup.

Bonne journée

Cordialement