Archive qui génère automatiquement un numéro

[Lenul]

Bonjour a tous les experts d'excel,

Depuis peu je me passione pour excel et j'ssaie don d'améliorer tout une liste de fichiers démodés utilisés tous les jours.

Je voudris créer un fichier qui génère un numéro d'archie interne (CPXXXX) a chaque fois qu'on active la macro et archive les données enregistrées dans une liste.

Ci joint le fichier.
Explications:
Addressed to: (nom de l'utilisateur manuel)
Date: (date a enregistrer manuellement)
Internal Ref: (référence interne manuelle)
Matricule: (numéro d'utilisateur interne manuel)
User: générer l'utilisateur automatiquement?
Numéro CP: générer un numéro CPXXXX à travaers une macro. (voir Database)
Delete number: Supprimer une ligne de la liste

Toutes ces données devront être stockées dans la feuille Database lorsqu'on appuie sur la macro.

Je sais que c'est beaucoup demandé, mais j'espère qu'il y a qn. qui trouvera le temps de se pencher sur la question.

Ci joint vous trouverez le fichier en question.
Bonne journée à tous et Merci d'avance.
Lenul

 

[Fichier]

 

[Lenul]

Voici le fichier en question....
Oufff... j'ai eu du mal...

 

[_Thierry]

Bonjour

Je pense que tu devrais regarder déjà ce tutoriel en animation flash qui te permettra de mieux comprendre comment joindre un fichier sur ce Forum

Comment Joindre un Fichier sur XLD

Bon Aprèm
[ol]@+Thierry[/ol]

 

[Lenul]

Merci Thierry pour la démo!!!
[file name=GenerateCP.zip size=3178]http://www.excel-downloads.com/components/com_simpleboard/uploaded/files/GenerateCP.zip[/file]

 

[_Thierry]

Re Bonjour,

Déjà tu peux commencer par supprimer ta formule de concaténation dans la colonne 'D' de la feuille 'Database'... Sinon celà va géner VBA...

Ensuite pour ton Bouton 'Generate' :

Sub GenerateNewRecord()
Dim LastCell As Range
Dim LastNum As Long
Dim NewNum As Long

With Sheets('Database')
        Set LastCell = .Range('D65536').End(xlUp)
End With

    With Sheets('Generate')
            LastNum = Val(Right(LastCell, 5))
            NewNum = LastNum + 1
            LastCell.Offset(1, 0) = 'CP' & Format(NewNum, '00000')
            LastCell.Offset(1, 1) = .Range('D6')
            LastCell.Offset(1, 2) = .Range('D4')
            LastCell.Offset(1, 3) = .Range('D8')
            LastCell.Offset(1, 4) = .Range('D10')
            LastCell.Offset(1, 5) = .Range('D12')
    End With

End Sub

Et pour ton bouton 'Delete' :

Sub DeleteAnExistingRecord()
Dim Plage As Range, Cell As Range
Dim TheRecord As String
Dim TheMessage As String
Dim c As Byte, RowToDelete As Integer
Dim Confirmation As Byte

TheRecord = Sheets('Generate').Range('D16')
If TheRecord = '' Then Exit Sub

With Sheets('Database')
        Set Plage = .Range(.Range('D2'), .Range('D65536').End(xlUp))
End With

    For Each Cell In Plage
        If Cell = TheRecord Then
            For c = 0 To 5
                TheMessage = TheMessage & Cell.Offset(0, c) & vbCrLf
            Next
            RowToDelete = Cell.Row
            Exit For
        End If
    Next Cell
   
If Not RowToDelete = 0 Then
    Confirmation = MsgBox('Voulez vous supprimer Enregistrement suivant ?' & vbCrLf & _
                          TheMessage, vbQuestion + vbYesNo, 'Confirmation Suppression')
   
    If Confirmation = vbYes Then
        Sheets('Database').Rows(RowToDelete).EntireRow.Delete
    End If
Else
MsgBox 'Ref ' & TheRecord & ' not found !!!'

End If
End Sub

Pour autant que j'ai compris que l'on cherchait un numéro 'CP' de la colonne 'D' à supprimer avec sa ligne entière (?)...

Bonne Fin de Journée
[ol]@+Thierry[/ol]

PS Je n'avais pas vu cette question là... pour générer un User 'Automatiquement' selon ce que tu cherches, tu as :

Sub TheUser()
MsgBox Application.UserName 'Du Menu Outils Option
MsgBox Environ('UserName') 'Du Log In de NetWork/WorkStation
End Sub

Bye bye et bon courage !

Message édité par: _Thierry, à: 08/03/2006 17:28

 

[Lenul]

Bonjour Thierry!!

C'est supergénial ce que tu as fait! Franchement j'en suis encore tout épaté. Je n'ai jamais eu l'occasion de me pencher plus que cela sur l'éditeur de macros VBA. Je viens de me commander des bouquins pour me former un peu...

J'ai juste une autre question, mais ne te sens pas obligé de me donner la solution... je ne veux ni abuser de toi ... ni devenir un banal profiteur...

Est-il possible de modifier la macro du bouton Generate pour qu'elle vérifie d'abord si il y a des trous dans la numérotation et remplisse dabord ces trous... (après avoir fait un delete sur un numéro)....

Encore un très grans merci pour tout ce que tu m'as apris...
Lenul...

 

[Lenul]

Bonjour Thierry!!

C'est supergénial ce que tu as fait! Franchement j'en suis encore tout épaté. Je n'ai jamais eu l'occasion de me pencher plus que cela sur l'éditeur de macros VBA. Je viens de me commander des bouquins pour me former un peu...

J'ai juste une autre question, mais ne te sens pas obligé de me donner la solution... je ne veux ni abuser de toi ... ni devenir un banal profiteur...

Est-il possible de modifier la macro du bouton Generate pour qu'elle vérifie d'abord si il y a des trous dans la numérotation et remplisse dabord ces trous... (après avoir fait un delete sur un numéro)....

Encore un très grans merci pour tout ce que tu m'as apris...
Lenul...

 

[_Thierry]

Salut !

Heureux de pouvoir t'aider mais ultra à la bourre !

Tu peux essayer ceci, mais je pense vraiment qu'on pourrait améliorer...

Option Explicit

Sub GenerateNewRecord()
Dim PlageToScan As Range, Cell As Range
Dim LastCell As Range
Dim LastNum As Long
Dim NewNum As Long
Dim x As Long
Dim RowToInsert As Long
Dim CellCible As Range

With Sheets('Database')
        Set LastCell = .Range('D65536').End(xlUp)
        Set PlageToScan = .Range(.Range('D2'), LastCell)
        x = Val(Right(.Cells(2, 4), 5))
End With
   
   
    For Each Cell In PlageToScan
        If Not x = Val(Right(Cell, 5)) Then
            RowToInsert = Cell.Row
            Exit For
        End If
        x = x + 1
    Next Cell


Select Case RowToInsert
Case 0
    Set CellCible = LastCell
Case Else
    With Sheets('Database')
        .Rows(RowToInsert).Insert Shift:=xlDown
        Set CellCible = .Cells(RowToInsert - 1, 4)
    End With
End Select

    With Sheets('Generate')
            LastNum = Val(Right(CellCible, 5))
            NewNum = LastNum + 1
            CellCible.Offset(1, 0) = 'CP' & Format(NewNum, '00000')
            CellCible.Offset(1, 1) = .Range('D6')
            CellCible.Offset(1, 2) = .Range('D4')
            CellCible.Offset(1, 3) = .Range('D8')
            CellCible.Offset(1, 4) = .Range('D10')
            CellCible.Offset(1, 5) = .Range('D12')
    End With

End Sub

Bonne Soirée
[ol]@+Thierry[/ol]

 

[Lenul]

C'est incroyable!!!! Ca marche!
Je ne pourrais jamais te dire assez merci... et là j'ai une dernière faveur à te demander... après je te laisserais tranquil...

Est-il possible de copier à chaque fois qu'un numéro est généré de le copier dans la feuille Generate D14??

J'ai un problème avec tous ceux qui sont créés après avoir été supprimés...

Je m'excuse de te demander toujours plus... mais là c'est ma dernière demande...

Mille mercis!!! C'est supersympa!!!

 

[Lenul]

Merci pour tout ce que tu m'as apris!!
Passe une excellente journée,
Pedro

 

[_Thierry]

Bonjour,

Bon et bien on a (j'ai !!!) de la chance !!! lol

Pour ta dernière demande pas vraiment certain d'avoir tout suivi ?

Essaie ceci enfin de macro :

With Sheets('Generate')
LastNum = Val(Right(CellCible, 5))
NewNum = LastNum + 1
CellCible.Offset(1, 0) = 'CP' & Format(NewNum, '00000')
CellCible.Offset(1, 1) = .Range('D6')
CellCible.Offset(1, 2) = .Range('D4')
CellCible.Offset(1, 3) = .Range('D8')
CellCible.Offset(1, 4) = .Range('D10')
CellCible.Offset(1, 5) = .Range('D12')
.Range('D14') = 'CP' & Format(NewNum, '00000')
End With


Bonne Journée
[ol]@+Thierry[/ol]

 

[Lenul]

Bonjour Thierry,

Je voulais te remercier pour tous tes conseils. (désolé pour la réponse tardive) J'ai appliqué tout ce que tu m'as apris et même rajouté de nouvelles règles. Je vais devenir un mordu du Forum... je le sens...

Merci pout tout,
Passe une excellente journée,
Pedro