Matricule alphanumérique en associant le nom de l’onglet, l’année en cours et un compteur de trois c

ksimat

XLDnaute Junior
Bonjour à toutes et à tous,

Je sais qu’il y a eu sur le NET plusieurs postes sur ce sujet mais je n’ai malheureusement pas trouvé de réponse qui règle mon problème. Je voudrais dans une petite base de données générer par macro des matricules automatiques qui seraient composés du nom de l’onglet + l’année en cours + un compteur de trois chiffres commençant par 001.

Je voudrais dès que je saisis le nom de la personne à inscrire en (B2), un matricule alphanumérique lui soit automatiquement assigné en (A2) en récupérant le nom de l'onglet + l’année en cours suivi 3 chiffres (001).

Exemple: Sous l’onglet dénommé MAS le matricule de toto devrait être MAS2017001, celui de son suivant MAS2017002.

Je joins un fichier test pour de plus amples détails.

Merci d’avance à tous ceux qui passeront.

Ksimat
 

Fichiers joints

Dernière édition:

M12

XLDnaute Impliqué
Bonjour,
Teste avec cette formule à mettre en A2 de chaque onglet et tirer vers le bas
Code:
=SI(B2="";"";DROITE(CELLULE("nomfichier");3)&ANNEE(AUJOURDHUI())&TEXTE(LIGNE(A1);"000"))
 

DoubleZero

XLDnaute Barbatruc
Bonjour, ksimat, M12,

Autre possibilité avec le code ci-après, logé dans ThisWorkbook :
VB:
Option Explicit
Private Sub Workbook_SheetChange(ByVal o As Object, ByVal c As Range)
    Select Case o.Name
    Case "MAS", "DRK", "KLM"
        If c.Column <> 2 Or c.Row < 2 Or c.Count > 1 Then Exit Sub
        With Selection.Offset(-1, -1)
            .Offset(, 16).Value = "=Text(Row()-1, ""000"")"
            .Value = o.Name & Year(Date) & .Offset(, 16)
            .Offset(, 16) = ""
        End With
        If c = "" Then c.Offset(, -1) = ""
    End Select
End Sub
A bientôt :)
 

ksimat

XLDnaute Junior
Bonjour M12, DoubleZerro et à tous les autres,
D'abord un grand MERCI pour votre aide. J'ai testé les deux propositions (la formule de M12 et la macro de DoubleZerro); toutes les deux marchent mais chacune avec un petit handicap. Pour la formule à tirer dans la colonne A, je veux l'écarter car la colonne est déjà utilisée par une autre fonction dans une macro
Sheets(s).[A1].CurrentRegion.Offset(1, 0).Copy _
Sheets("RECAPITULATIF").[A65000].End(xlUp).Offset(1, 0) .
Quant à la macro de DoubleZerro elle ferait l'affaire sauf que le matricule qui doit nécessairement être inscrit dans la cellule de gauche c'est à dire en colonne A, est mis dans la cellule d'en haut si je valide par la touche de direction DROITE. Si je valide l'inscription en B2 par la touche ENTER ou la touche de direction BAS, le matricule est inscrit au bon endroit en A2. Et jamais je quitte la B2 par la touche GAUCHE, alors là boum : BUG.
Je ne m'y connais pas trop en vba mais j'ose soupçonner que ce problème vient de la ligne [ With Selection.Offset(-1, -1) ].

Voilà, en espérant d'avoir été assez clair dans mes explications laborieuses, je vous redis merci.
Ksimat
 

Fichiers joints

DoubleZero

XLDnaute Barbatruc
Re-bonjour,

Est-ce mieux comme ceci ?
VB:
Option Explicit
Private Sub Workbook_SheetChange(ByVal o As Object, ByVal c As Range) ' v2
    Select Case o.Name
    Case "MAS", "DRK", "KLM"
        If c.Column <> 2 Or c.Row < 2 Or c.Count > 1 Then Exit Sub
        c.Name = "toto"
        With Range("toto").Offset(, -1)
            .Offset(, 16).Value = "=Text(Row()-1, ""000"")"
            .Value = o.Name & Year(Date) & .Offset(, 16)
            .Offset(, 16) = ""
        End With
        If c = "" Then c.Offset(, -1) = ""
    End Select
End Sub
A bientôt :)
 

ksimat

XLDnaute Junior
Re-Bonjour DoubleZerro,
A priori cela semble convenir. Mais je vais pousser les test plus loin et je vous reviens.
Merci pour tout!
Ksimat
 

ksimat

XLDnaute Junior
Salutations à tous particulièrement à DoubleZerro,
DoubleZerro votre macro marche à merveille. Je l'ai testé et éprouvé dans "toutes" les situations et elle demeure irréprochable et moi très satisfait. J'ai cherché et vu "les fleurs" (sic) qui se cachent dans la macro sauf qu'il me reste à comprendre le pourquoi du "16" de .Offset(, 16). J'espère dénicher cette pétale.
Je valide: Il y a des fleurs partout pour qui veut bien les voir. (Henri MATISSE)
Encore MERCI
Ksimat
 

DoubleZero

XLDnaute Barbatruc
Re-bonjour,
... J'ai cherché et vu "les fleurs" (sic)...
Merci, ksimat :D !

... il me reste à comprendre le pourquoi du "16" de .Offset(, 16)...
Je n'ai pas su faire autrement :( que d'insérer en colonne q le format personnalisé "000" qui sera, par la suite, précédé du nom d'onglet et de l'année.

Afin de mieux comprendre :

remplacer
Code:
.Offset(, 16) = ""
par
Code:
'.Offset(, 16) = ""
Ne pas hésiter à demander d'autres explications.

A bientôt :)
 

ksimat

XLDnaute Junior
Re-Bonjour DoubleZerro,
WAW! J'ai vu et trouvé. Et quelle FLEUR! :eek:
j'en ai profité pour le décaler dans une colonne plus éloignée [ .offset(, 51) ] car la (, 16) est prévu pour recevoir des données. Vous remarquerez que cette "fleur" commence déjà à donner des "fruits". ;)
Ce soir je dormirai moins bête grâce à ce forum et à ses membres.
Toute ma gratitude à tous particulièrement à DoubleZerro et à M12.
Merci
Ksimat
 

ChTi160

XLDnaute Barbatruc
Bonsoir Ksimat
Bonsoir Le Fil ,DoubleZero ,le forum
une possibilité peut être , d'éviter le Offset(,16)
VB:
Private Sub Workbook_SheetChange(ByVal o As Object, ByVal c As Range) ' v2
    Select Case o.Name
    Case "MAS", "DRK", "KLM"
        If c.Column <> 2 Or c.Row < 2 Or c.Count > 1 Then Exit Sub
          With c.Offset(, -1)
                     .Value = o.Name & Year(Date) & Format(.Row - 1, "000")
          End With
        If c = "" Then c.Offset(, -1) = ""
    End Select
End Sub
Bonne fin de Soirée
Amicalement
Jean marie
 

ksimat

XLDnaute Junior
Bonsoir Jean Marie, le fil et tous ceux qui passeront,
Je confirme que "cette voie de contournement" est aussi efficace et pertinente.
Merci pour la leçon.
Ksimat
 

ksimat

XLDnaute Junior
Bonjour à toutes et tous ceux qui passeront,

Je me permets de relancer ce fil que j’avais ouvert il y a quelques jours. De bonnes volontés (DoubleZerro et ChTi160 notamment – je continue de les remercier toujours) m’avaient trouvé le code ci-dessous qui me permet de générer automatiquement en colonne A un matricule dès qu’un prénom est saisi en colonne B. La macro fonctionne tant que la saisie se fait par clic en cellules de la colonne B. Mais (parce qu’il y a un « mais ») si une liste de prénoms est copiée ailleurs puis collée dans la colonne B, les matricules ne sont plus générés automatiquement. Pour ce faire il faut faire un double-clic sur chaque prénom (cellule B) de la liste collée pour déclencher la génération de chaque matricule ou copier et coller les éléments de la liste un par un.

Je voudrais, si possible, pouvoir insérer les données par liste copiée et collée. Je joins mon fichier de test en réitérant mes remerciements à toutes les personnes qui voudront bien se pencher sur mon problème.

Ksimat

Private Sub Workbook_SheetChange(ByVal o As Object, ByVal c As Range) ' v2
Select Case o.Name
Case "MAS", "DRK", "KLM"
If c.Column <> 2 Or c.Row < 2 Or c.Count > 1 Then Exit Sub
With c.Offset(, -1)
.Value = o.Name & Year(Date) & Format(.Row - 1, "000")
End With
If c = "" Then c.Offset(, -1) = ""
End Select
End Sub
 

Fichiers joints

ChTi160

XLDnaute Barbatruc
Bonjour ksimat
Bonjour le Fil ,Le Forum
une approche
VB:
Private Sub Workbook_SheetChange(ByVal o As Object, ByVal c As Range) ' v2
Dim oC As Range
    With Application
         .ScreenUpdating = False
    End With
If c.Column <> 2 Or c.Row < 2 Then Exit Sub 'si colonne differente de la 2 et Ligne inferieure a 2 "On quitte"
If c.Rows.Count = 1 Then 'si la plage traite est composee d'une ligne
 Select Case o.Name 'selon le nom de la feuille ou a lieu le Changement
        Case "MAS", "DRK", "KLM" 'si le Nom est l'un de de ces Noms
            With c.Offset(, -1) 'Avec la cellule à gauche de la cellule concernée
                  .Value = o.Name & Year(Date) & Format(.Row - 1, "000") 'on colle les donnees ainsi definies
            End With
        If c = "" Then c.Offset(, -1) = "" 'si la cellule concernée est Vide on vide la Cellule à sa gauche
 End Select
   ElseIf c.Rows.Count > 1 Then 'si la plage traitee est composee de plus d'une ligne
  For Each oC In c 'pour chaque lignes de cette Plage
     Select Case o.Name 'selon le nom de la feuille ou a lieu le Changement
        Case "MAS", "DRK", "KLM" 'si le Nom est l'un de de ces Noms
        With oC.Offset(, -1)
        .Value = o.Name & Year(Date) & Format(.Row - 1, "000") 'on colle les donnees ainsi definies
        End With
        If oC = "" Then oC.Offset(, -1) = ""  'si la cellule concernée est Vide , on vide la Cellule à sa gauche
     End Select
  Next oC
End If
    With Application
         .CutCopyMode = False
         .ScreenUpdating = True
    End With
End Sub
Bonne Journée
Amicalement
Jean marie
 

Fichiers joints

ksimat

XLDnaute Junior
Bonjour ChTi160, les autres,
Ça marche! Merci mille fois et surtout pour la pédagogie. J'ai bien aimé les commentaires sur la structuration et la portée des instructions de la macro. Cela m'a permis de comprendre le pourquoi du blocage et le comment de la solution apportée. D'autres néophytes qui passeront apprendront la leçon car j'ai fait mes plus grandes acquisitions en parcourant les fils ouverts par les autres. Je remercie tous les membres de ce site.

MERCI maître ChTi160!
Et bonne journée à vous aussi!
Ksimat
 

eriiiic

XLDnaute Barbatruc
Bonjour,

autre façon un peu allégée :
VB:
Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
    Dim pl As Range, c As Range
    Select Case Sh.Name
    Case "MAS", "DRK", "KLM"
        Set pl = Intersect(Target, Sh.Columns(2), Sh.[2:999])    '999 car limité à 3 chiffres
        If Not pl Is Nothing Then
            For Each c In pl
                If c = "" Then
                    c.Offset(, -1) = ""
                Else
                    With c.Offset(, -1)
                        Application.EnableEvents = False
                        .Value = Sh.Name & Year(Date) & Format(.Row - 1, "000")
                        Application.EnableEvents = True
                    End With
                End If
            Next c
        End If
    End Select
End Sub
eric
 

ChTi160

XLDnaute Barbatruc
Re
Bonjour Eriiiic
Bonjour Le Fil,Le Forum
afin de ne pas se limiter en Lignes Lol
VB:
Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
    Dim pl As Range, c As Range
    Select Case Sh.Name
    Case "MAS", "DRK", "KLM"
        Set pl = Intersect(Target, Sh.Columns(2))    '
        If Not pl Is Nothing Then
             For Each c In pl
                    c.Offset(, -1) = IIf(c = "", "", Sh.Name & Year(Date) & Format(c.Row - 1, "####000"))
            Next c
        End If
    End Select
    Application.CutCopyMode = False
End Sub
merci
Bonne fin de Journée
Amicalement
Jean marie
 
Dernière édition:

ksimat

XLDnaute Junior
Bonjour eriiic, le fil,
eriiiic , merci pour votre code qui marche parfaitement. Mais excusez mon ignorance si je ne comprend pas bien la ligne [ Set pl = Intersect(Target, Sh.Columns(2), Sh.[2:999]) '999 car limité à 3 chiffres].
Merci d'avance à quiconque pourrait éclairer ma lanterne.
Ksimat
 

eriiiic

XLDnaute Barbatruc
Calcul l'intersection entre la plage du collé et la plage qui t'intéresse B2:Bx.
Et si cette intersection n'est pas vide, applique la formule pour toutes ses cellules.
eric
 

Discussions similaires


Haut Bas