Microsoft 365 Incrémenter cellule automatiquement à chaque nouvelle ligne

[fredzertya]

Bonjour, je souhaite dans un tableau article, faire en sorte, que à chaque fois qu'une nouvelle ligne est créée, la colonne "code barre" s'incrémente pour donner un ID diffèrent à chaque article.

J'ai un code qui va pas trop mal, il demande de créer une ligne et remplir une des cellules pour incrémenter la colonne code barre SB-00001, SB-00002 etc..

Comment faire pour que l'incrémentation ne dépende pas de la case à remplir et incrémente la cellule code barre uniquement à chaque insertion d'une nouvelle ligne ?

Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)
Dim strWS As String
Dim lRow As Long, lCounter As Long
Dim x As String

    If Target.ListObject Is Nothing Then Exit Sub

    strWS = Me.Name: x = "SB-": lRow = Target.Row

    Select Case Target.Column
        Case 2
            lCounter = Me.ListObjects(1).ListRows.Count
            If IsEmpty(Target.Offset(, -1)) Then Cells(lRow, 21) = x & Format(lCounter, "00000")
        Case 5
            If Not IsEmpty(Target) Then Cells(lRow, "O").Value = strWS Else Cells(lRow, "O") = ""
        Case 8
            If Not IsEmpty(Target) Then Cells(lRow, "M").Value = "Transmis" Else Cells(lRow, "M") = ""
        Case Else
            '
    End Select
End Sub

 

[Dudu2]

Bonjour,

Quelques remarques:
- On oublie souvent que le Target d'un SelectionChange() ou d'un Change() peut être un Range de plusieurs cellules voire de plusieurs Areas.
- Ce serait mieux d'utiliser le nom du tableau plutôt que son numéro dans ListObjects().
- Ce serait mieux d'utiliser le nom de la colonne Code Barre plutôt que son numéro dans ListColumns().
- Comme je ne sais pas si tu veux gérer les insertions et suppressions de lignes dans ton tableau, j'ai mis une constante préprocesseur à valoriser selon le cas.
- Quand on fait des modifs dans la gestion d'un évènement de Change() il faut, sauf cas particulier, inhiber la gestion des évènements pour ne pas générer d'appels récursifs (et inutiles voire destructeurs) à la fonction.

#Const GérerInsertionSuppressionLignes = True

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim Cellule As Range
    Dim NoLigneTableau  As Long
    Dim NoColonneTableau  As Long
    Dim i As Long
    Const NoColonneCodeBarre = 1
  
    If Me.ListObjects(1).DataBodyRange Is Nothing Then Exit Sub
    If Intersect(Target, Me.ListObjects(1).DataBodyRange) Is Nothing Then Exit Sub

    'Pour chaque cellule modifiée
    For Each Cellule In Target.Cells
  
        'Si la cellule est dans le tableau
        If Not Intersect(Cellule, Me.ListObjects(1).DataBodyRange) Is Nothing Then
            NoColonneTableau = Cellule.Column - Me.ListObjects(1).DataBodyRange.Column + 1
            NoLigneTableau = Cellule.Row - Me.ListObjects(1).DataBodyRange.Row + 1
            'MsgBox NoLigneTableau & " " & NoColonneTableau
          
            'Vérifier si le Code Barre est présent et sinon le remplir
            If IsEmpty(Me.ListObjects(1).ListColumns(NoColonneCodeBarre).DataBodyRange.Cells(NoLigneTableau)) Then
                'Ajoute le Code Barre dans la ligne
                Application.EnableEvents = False
                Me.ListObjects(1).ListColumns(NoColonneCodeBarre).DataBodyRange.Cells(NoLigneTableau).Value = "SB-" & NoLigneTableau
                Application.EnableEvents = True
            End If
              
#If GérerInsertionSuppressionLignes Then
            'Si insertion ou suppression de ligne au milieu du tableau, corriger les autres Codes Barre
            Application.EnableEvents = False
            For i = NoLigneTableau To Me.ListObjects(1).DataBodyRange.Rows.Count
                If Me.ListObjects(1).ListColumns(NoColonneCodeBarre).DataBodyRange.Cells(i).Value <> "SB-" & i Then
                    Me.ListObjects(1).ListColumns(NoColonneCodeBarre).DataBodyRange.Cells(i).Value = "SB-" & i
                End If
            Next i
            Application.EnableEvents = True
#End If
        End If
    Next Cellule
End Sub

 

[fredzertya]

Bonjour,


Merci Dudu2,

Je viens de tester en changeant simplement le numéro de colonne 21 correspondant à la colonne code_barre, il y a du mieux le tableau est alimenté par une appli power apps, il y avait des ratés, a la création d'une nouvelle ligne, ou le code barre n'était pas affecté, alors que là il n'y a plus le phénome.

Il y a 3 problèmes:

L'ID article est le code barre, il doit être unique par article et ne jamais changer, même en cas de modification/suppression.

L'ID affecté code_barre doit s'incrémenter par rapport au nombre de ligne créée dans le tableau, ou au mieux par rapport au code barre existant dans la colonne code barre, sans correspondre au numéro de ligne.

Le format du code barre n'a plus les 0, par exemple SB-000001

------------------------------------------------------
Le tableau s'appel BDD, la colonne code_barre, n°21
------------------------------------------------------

L'idée est de générer un ID par article automatiquement, qui sera le code barre

Merci par avance,

 

[job75]

Bonjour fredzertya, Dudu2, le forum,

Cette macro utilise une formule matricielle pour créer les codes-barres :

Private Sub Worksheet_Change(ByVal Target As Range)
Dim r As Range
Set r = [BDD[code_barre]] 'colonne du tableau structuré
r.Name = "Code" 'plage nommée
Application.ScreenUpdating = False
Application.EnableEvents = False
For Each r In r
    If Not r Like "SB-#*" Then r = ["SB-"&TEXT(MAX(IFERROR(--SUBSTITUTE(Code,"SB-",),))+1,"000000")] 'formule matricielle
Next
Application.EnableEvents = True
End Sub

A+

 

[Dudu2]

Excellente proposition de Job75 (qui me dépasse ) !

 

[job75]

S'il y a beaucoup de lignes l'évaluation des formules matricielles prendra du temps donc utilisez :

Private Sub Worksheet_Change(ByVal Target As Range)
Dim r As Range, tablo, i&, n&, maxi&
Set r = [BDD[code_barre]] 'colonne du tableau structuré
r.Name = "Code" 'plage nommée
tablo = r.Resize(, 2) 'matrice plus rapide, au moins 2 éléments
For i = 1 To UBound(tablo)
    n = Val(Replace(tablo(i, 1), "SB-", ""))
    If n > maxi Then maxi = n
Next
Application.ScreenUpdating = False
Application.EnableEvents = False
For i = 1 To UBound(tablo)
    If Not tablo(i, 1) Like "SB-#*" Then maxi = maxi + 1: r(i) = "SB-" & Format(maxi, "000000")
Next
Application.EnableEvents = True
End Sub

Fichier (2).

 

[job75]

Le tableau n'ayant que 2 lignes entrez simultanément le texte "xxx" dans la plage B2:B10000.

Chez moi sur Excel 2019, fichier(1) => 42 secondes, fichier(2) => 0,37 seconde.

 

[fredzertya]

Je viens de tester dans tous les sens, suppression, ajout de ligne, milieu, haut bas, et c'est vraiment bien, merci beaucoup à vous deux.

Bonne soirée