Insérer un compteur dans les onglets créer VBA

Bonjour a toutes et tous, Forum

Je souhaiterai svp insérer un compteur dans le code ci-joint , sachant que le code sert à dispatcher les données sur des ongles créées

Option Explicit
Sub test()
Dim a, e, dico As Object, wsName As String
    Application.ScreenUpdating = False
    Set dico = CreateObject("Scripting.Dictionary")
    With Sheets("Feuil1")
        With .Range("a1").CurrentRegion
            a = .Columns(21).Offset(1).Resize(.Rows.Count - 1).Value
            For Each e In a
                If Not dico.exists(e) Then
                    dico(e) = Empty
                    wsName = e
                    If Not Evaluate("isref('" & wsName & "'!a1)") Then
                        Sheets.Add(after:=Sheets(Sheets.Count)).Name = wsName
                    End If
                    Sheets(wsName).Cells.Delete
                    .AutoFilter 21, e
                    .SpecialCells(xlCellTypeVisible).Copy Sheets(wsName).Cells(1)
                    .AutoFilter
                End If
            Next
        End With
    End With
     Set dico = Nothing
    Application.ScreenUpdating = True
End Sub

Merci d'avance pour votre aide.

Cordialement,

Bonjour,

Un compteur de quoi?

Si c'est pour compter les onglets crées, alors ceci:

Option Explicit

Sub test()
    Dim a, e, dico As Object, wsName As String
    Dim Cpt As Long
    Application.ScreenUpdating = False
    Set dico = CreateObject("Scripting.Dictionary")
    With Sheets("Feuil1")
        With .Range("a1").CurrentRegion
            a = .Columns(21).Offset(1).Resize(.Rows.Count - 1).Value
            For Each e In a
                If Not dico.exists(e) Then
                    dico(e) = Empty
                    wsName = e
                    If Not Evaluate("isref('" & wsName & "'!a1)") Then
                        Sheets.Add(after:=Sheets(Sheets.Count)).Name = wsName
                        Cpt = Cpt + 1
                    End If
                    Sheets(wsName).Cells.Delete
                    .AutoFilter 21, e
                    .SpecialCells(xlCellTypeVisible).Copy Sheets(wsName).Cells(1)
                    .AutoFilter
                End If
            Next
        End With
    End With
    MsgBox "Nombre d'onglets créés = " & Cpt
    Set dico = Nothing
    Application.ScreenUpdating = True
End Sub

Cdlt

Bonjour Arturo83

Bonjour le forum,

Alors ceci:

Option Explicit

Sub test()
    Dim a, e, dico As Object, wsName As String
    Dim Message As String
    Application.ScreenUpdating = False
    Set dico = CreateObject("Scripting.Dictionary")
    With Sheets("Feuil1")
        With .Range("a1").CurrentRegion
            a = .Columns(21).Offset(1).Resize(.Rows.Count - 1).Value
            For Each e In a
                If Not dico.exists(e) Then
                    dico(e) = Empty
                    wsName = e
                    If Not Evaluate("isref('" & wsName & "'!a1)") Then
                        Sheets.Add(after:=Sheets(Sheets.Count)).Name = wsName
                        Cpt = Cpt + 1
                    End If
                    Sheets(wsName).Cells.Delete
                    .AutoFilter 21, e
                    .SpecialCells(xlCellTypeVisible).Copy Sheets(wsName).Cells(1)
                    .AutoFilter
                    Message = Message & Chr(10) & "feuille " & Sheets(wsName).Name & " - " & Sheets(wsName).Range("A" & Rows.Count).End(xlUp).Row
                End If
            Next
        End With
    End With
    MsgBox "Nonbre de lignes trouvées " & Chr(10) & Message
    Set dico = Nothing
    Application.ScreenUpdating = True
End Sub

Cdlt

desoler Arturo83

le compteur dans chacun des tableaux du feuil crée pour incrémenter les lignes

Excusez moi si je ne l'ai pas expliqué correctement.

Cdlt

Désolé, je ne comprends pas, d"autant plus que je n'ai pas de fichier représentatif sous la main, vos explications sont insuffisantes.

Pour gagner du temps, déposez 2 fichiers, un avant répartition, un deuxième après répartition et ce que vous souhaitez comptabiliser.

Faites 2 fichiers "bidons" avec une dizaine de lignes et sans données confidentielles.

Bonjour,

Tu nous présente un code que tu nous demandes d'autopsier dans le but d'obtenir un résultat incompréhensible.

Explique nous ce qu'est sensé faire ce code et comme il obtient ce résultat.

Bonjour dysorthographie

Bonjour Le forum

Je vais essayer de l'expliquer plus clairement.
j'aimerai rajouter à mon compteur de boucle de code VBA qui sert à incrémenter les lignes des nouveaux onglets.
Je veux faire apparaître dans la colonne A Incrémentation automatique les lignes.

Merci d'avance pour vos réponses.

Bien cordialement,

Votre code modifié:

Sub test()
Dim a, e, dico As Object, wsName As String
Dim Nb_Lig As Long, i As Long
    Application.ScreenUpdating = False
    Set dico = CreateObject("Scripting.Dictionary")
    With Sheets("Feuil1")
        With .Range("a1").CurrentRegion
            a = .Columns(22).Offset(1).Resize(.Rows.Count - 1).Value
            For Each e In a
                If Not dico.exists(e) Then
                    dico(e) = Empty
                    wsName = e
                    If Not Evaluate("isref('" & wsName & "'!a1)") Then
                        Sheets.Add(after:=Sheets(Sheets.Count)).Name = wsName
                    End If
                    Sheets(wsName).Cells.Delete
                    .AutoFilter 22, e
                    .SpecialCells(xlCellTypeVisible).Copy Sheets(wsName).Cells(1)
                    .AutoFilter
                End If
            Next
        End With
    End With

    'numérotation
    For i = 1 To Sheets.Count
        If Sheets(i).Name <> "Feuil1" Then
            With Sheets(i)
                Nb_Lig = .Range("A" & Rows.Count).End(xlUp).Row
                .Columns("A:A").Insert Shift:=xlToRight
                .Range("A1").FormulaR1C1 = "N°"
                .Range("A2:A" & Nb_Lig).FormulaR1C1 = "=ROW()-1"
                .Range("A2:A" & Nb_Lig).Value = .Range("A2:A" & Nb_Lig).Value
            End With
        End If
    Next
    Set dico = Nothing
    Application.ScreenUpdating = True
End Sub

Cdlt

Bonjour Arturo83, Bonjour à tous,

Ç’est exactement ce que je voulais ,Cela fonctionne parfaitement, merci !!

Encore une fois un très grand merci

Bien cordialement,