Autres chalenge vba

patricktoulon · Hier à 00:41

salut à tous
je doit créer des Ids une par une avec un bouton ou créer a la chaine tout un paquet d'id sans faire de doublons à coup sur
le chalenge c'est de faire sans RND
et pour couronner le tout la seule donnée disponible que l'on peut utiliser c'est le nombre d'id déjà créés

je donnerais ma méthode quand il y aura eu quelques participations

les condition d’élaborations pour la fonction

ne doit pas faire appel a la fonction RND
ne doit pas faire appel a un name ou registre ou toute autre source de memoring
elle doit s'auto suffire
et le must si je transfert cette fonction dans un autre classeur( et même plus loin , autre pc) elle ne doit pas créer des id déjà crées au par avant

patricktoulon · Hier à 21:59

re
@Oui sylvanu c'est juste pour te montrer que le moteur va (difficile de calculer tu prend un peu plus d'une seconde pour 100 je prends 0.6xxx pour 60 000

mais dans tout les cas personne n'a trouver l'astuce pour justement ne pas retirer les même
alors je vous le dis
la chose et simple la fonction réécrit son propre ADN

Code:

'+------------------------------------------------------------+
'¦                        PATRICKTOULON                       ¦
'¦                   collection fonction perso DNA            ¦
'¦   FONCTION AUTOSUFFISANTE PATRICKIENNE — VERSION 1.0       ¦
'¦ Cette fonction est vivante.Elle réecrit son propre ADN.   ¦
'¦ Elle ne dépend de rien. Il ne laisse rien derrière ELLE.   ¦
'¦ Elle est unique...

patricktoulon · Hier à 20:45

j'ai réduit l'ecart à quelque secondes fait une compile
je n'ai plus le dépassement de capacité comme ca
je livre sans l'astuce encore pour le non repeat ou no re init
mais déjà sur 60 000 ids je n'ai jamais de doublons
et même encore laavec 60 000 ids je suis en dessous du temps d’exécution de @sylvanu

VB:

Sub tesouft()
    [A:A].Clear
    Const dat1S As Date = "01/01/1904 23:59:59"
    Const dat2S As Date = "01/01/1904 23:59:59"
    Const dat3S As Date = "01/01/1904 23:59:59"
    tim = Timer
    Nb = 60000
    ReDim tbl(1 To Nb)
    For i = 1 To Nb
        d = CDate(datS) + (i / 98)
        d2 = CDate(dat2S) + (i / 90)
        d3 = CDate(dat3S) + (i / 70)
        chaine = Split(Format(d, "dd:mm:yyyy:hh:nn:ss") & ":" & Format(d2, "hh:nn:ss") & ":" & Format(d3, "hh:nn:ss"), ":")
        cod = ""
        For e = 0 To UBound(chaine)
            cod = cod & Hex(chaine(e))
        Next
        'Debug.Print cod
        tbl(i) = cod
    Next
    MsgBox Timer - tim & " sec"
    Cells(1, 1).Resize(Nb) = Application.Transpose(tbl)
    DoEvents
    ActiveSheet.Range("$A$1:$A$60000").RemoveDuplicates Columns:=1, Header:=xlNo
    MsgBox ActiveSheet.UsedRange.Rows.Count - Nb & " doublon(s) trouvé"
End Sub

sylvanu · Hier à 20:59

@patricktoulon
Mais si vus relancez votre macro plusieurs fois vous obtenez toujours la même liste ?

mapomme · Hier à 20:59

Re,

Le résultat d'une expérience n'est pas une démonstration.

Le problème c'est qu'on doit montrer que, quelque soit la méthode qu'on utilise, la probabilité de doublon de la méthode est exactement nulle. Si on ne peut pas le démontrer alors il faudra vérifier que parmi tous les tirages déjà effectués aucun n'est égal au tirage qu'on vient juste de faire.

patricktoulon · Hier à 21:59

re
@Oui sylvanu c'est juste pour te montrer que le moteur va (difficile de calculer tu prend un peu plus d'une seconde pour 100 je prends 0.6xxx pour 60 000

mais dans tout les cas personne n'a trouver l'astuce pour justement ne pas retirer les même
alors je vous le dis
la chose et simple la fonction réécrit son propre ADN

Code:

'+------------------------------------------------------------+
'¦                        PATRICKTOULON                       ¦
'¦                   collection fonction perso DNA            ¦
'¦   FONCTION AUTOSUFFISANTE PATRICKIENNE — VERSION 1.0       ¦
'¦ Cette fonction est vivante.Elle réecrit son propre ADN.   ¦
'¦ Elle ne dépend de rien. Il ne laisse rien derrière ELLE.   ¦
'¦ Elle est unique                                            ¦
'¦ Copier-coller = clonage. Chaque clone poursuit l’histoire. ¦
'+------------------------------------------------------------+
Function Createid2(Optional Nb& = 1)
    Dim C As Long, vbcomp, vbXcomp, tim#, d As Date, d2 As Date, d3 As Date: ReDim tbl(1 To Nb)
   
    Const INITX_COUNTER As Long = 100
    Const dat1S As Date = "01/01/100 23:59:59"
    Const dat2S As Date = "01/01/100 23:59:59"
    Const dat3S As Date = "01/01/100 23:59:59" 'reprise
   
   
    For i = 1 To Nb
        C = INITX_COUNTER + i
        d = CDate(datS) + (C / 98)
        d2 = CDate(dat2S) + (C / 90)
        d3 = CDate(dat3S) + (C / 70)
        chaine = Split(Format(d, "dd:mm:yyyy:hh:nn:ss") & ":" & Format(d2, "hh:nn:ss") & ":" & Format(d3, "hh:nn:ss"), ":")
        cod = ""
        For e = 0 To UBound(chaine)
            cod = cod & Hex(chaine(e))
        Next
        'Debug.Print cod
        tbl(i) = cod
    Next
   
    Createid2 = tbl
   
    For Each vbXcomp In ThisWorkbook.VBProject.VBComponents
        If vbXcomp.CodeModule.CountOfLines > 0 Then
            If InStr(1, vbXcomp.CodeModule.Lines(1, vbXcomp.CodeModule.CountOfLines), "Const dat1S As Date", vbTextCompare) > 0 Then
                Set vbcomp = vbXcomp: Exit For
            End If
        End If
    Next
   
    For i = 1 To vbcomp.CodeModule.CountOfLines
        If InStr(vbcomp.CodeModule.Lines(i, 1), "Const INITX_COUNTER As Long") > 0 Then
            vbcomp.CodeModule.DeleteLines i, 4
            Exit For
        End If
    Next
    'MsgBox vbcomp.Name
    vbcomp.CodeModule.InsertLines i, " Const dat3S As Date = """ & Format(d, "dd/mm/yyyy hh:nn:ss") & """" & "'reprise"
    vbcomp.CodeModule.InsertLines i, " Const dat2S As Date = """ & Format(d2, "dd/mm/yyyy hh:nn:ss") & """"
    vbcomp.CodeModule.InsertLines i, " Const dat1S As Date = """ & Format(d3, "dd/mm/yyyy hh:nn:ss") & """"
    vbcomp.CodeModule.InsertLines i, " Const INITX_COUNTER As Long = " & C
   
End Function

Sub testcreateidbis()
    Dim Guids, tim#
    Guids = Createid2(100)
    Cells(1, 1).Resize(100) = Application.Transpose(Guids)
End Sub

encore les idées folle à Patrick ça 🤣 🤣 🤣

sylvanu · Aujourd'hui à 11:28

Bonjour,
J'ai testé votre macro sur deux PC avec W10 XL2007 et W11 XL2019, et j'ai obtenu la même liste d'ID :

Où ai je commis une erreur ?

mapomme · Aujourd'hui à 13:12

Bonjour à tous 😉,

VB:

    vbcomp.CodeModule.InsertLines i, " Const dat3S As Date = """ & Format(d, "dd/mm/yyyy hh:nn:ss") & """" & "'reprise"
    vbcomp.CodeModule.InsertLines i, " Const dat2S As Date = """ & Format(d2, "dd/mm/yyyy hh:nn:ss") & """"
    vbcomp.CodeModule.InsertLines i, " Const dat1S As Date = """ & Format(d3, "dd/mm/yyyy hh:nn:ss") & """"
    vbcomp.CodeModule.InsertLines i, " Const INITX_COUNTER As Long = " & C

On sauvegarde des données dans le code source de la macro me semble-t-il ? Ça ressemble quand même étrangement à une mise en mémoire au sein du classeur, non ?
De plus, le code source initial qu'on insère dans un nouveau classeur, lui, ne possède pas cette mémoire, non? C'est peut-être la source de ce que constate @sylvanu ?

sylvanu · Aujourd'hui à 13:30

Bonjour,
Comme la graine initiale est une constante, la même macro exécutée sur 2 PC ne peut donner que le même ID initial.
C'est là où je ne comprends pas la subtilité pour avoir 2 ID différents sur deux PC avec strictement la même macro.

Bernard_XLD · Aujourd'hui à 15:18

Bonjour le fil, le forum

Une idée, à voir, en conjuguant le résultat avec l'adresse mac, l'adresse mac étant unique au monde, on aurait forcément l'impossibilité d'avoir le même ID sur 2 PC différents

Cordialement

https://fr.wikipedia.org/wiki/Adresse_MAC

VB:

Sub Mac_ID()
Dim strCom As String
Dim objWMIService As Object
Dim colAdapters As Object
Dim objAdapter As Object
strCom = "."
Set objWMIService = GetObject("winmgmts:" & "!\\" & strCom & "\root\cimv2")
Set colAdapters = objWMIService.ExecQuery("Select * from Win32_NetworkAdapterConfiguration Where IPEnabled = True")
For Each objAdapter In colAdapters
MsgBox "MAC ID of this system : " & objAdapter.MACAddress
Next objAdapter
End Sub

lav · Aujourd'hui à 15:44

Bonjour, je ne sais si cela peut vous convenir, mais dans bien de langages de programmation existe une fonction pour obtenir un nom de fichier unique (un peu comme les GUID) , voire peut-être une fonction dans les APIs Windows qui fait la même chose. Son usage typique est la création de fichiers temporaires

lav · Aujourd'hui à 15:52

En .NET il y a

Path.GetRandomFileName()
Path.GetTempFileName()

patricktoulon · Aujourd'hui à 19:28

Bonsoir
non @sylvanu si tu a copié la fonction apres avoir fait un paqquet normalement les constante changent elle peuvent pas revenir toutes seul au point de départ
pour info j'ai testé 180 000 soit 3 fois 60 000 et aucun doublons a la sortie maintenant si tu copie dans un autre fichier avant de lancer c'est sur a un moment il vont te sortir les même mon but comme c'est sur une cle usb et que je ne veux pas salir les celle ou names le memo se fait en mettant a jour les constantes directement dans le code c'est sur que si tu fait marcher le truc sur deux pc deux classeurs différents là ca va pas coller

moi c'est juste le transfert de fichier qui compte voir pc et ca marche d'ailleurs lancer et regarder les conctantes a chaque fois

patricktoulon · Aujourd'hui à 19:41

sylvanu · Aujourd'hui à 20:57

Bonsoir Patrick,
Mais si nous sommes nombreux à copier votre macro dans un fichier vierge, alors nous serons nombreux à avoir les mêmes ID.

patricktoulon à dit:
et le must si je transfert cette fonction dans un autre classeur( et même plus loin , autre pc) elle ne doit pas créer des id déjà crées au par avant

Je pense que si je transfert cette fonction dans un autre classeur vierge elle va créer des id déjà crées auparavant.
Peut être que l' idée de Bernard permet d'éviter ce problème entre PC, et si on utilise l'heure cela réduit encore les incertitudes.

patricktoulon · Aujourd'hui à 21:48

re
et d'après toi j'utilise quoi @sylvanu
ou alors tu a l& réécriture ADN qui fonctionne pas
si je te dis que c'est impossible c'est que ça l'est
comment veux tu que elle te donne un déjà passé sachant quelle ne revient jamais en arrière

Autres chalenge vba

patricktoulon

XLDnaute Barbatruc

patricktoulon

patricktoulon

XLDnaute Barbatruc

sylvanu

XLDnaute Barbatruc

mapomme

XLDnaute Barbatruc

patricktoulon

XLDnaute Barbatruc

sylvanu

XLDnaute Barbatruc

mapomme

XLDnaute Barbatruc

sylvanu

XLDnaute Barbatruc

Bernard_XLD

XLDnaute Barbatruc

lav

XLDnaute Nouveau

lav

XLDnaute Nouveau

patricktoulon

XLDnaute Barbatruc

patricktoulon

XLDnaute Barbatruc

sylvanu

XLDnaute Barbatruc

patricktoulon

XLDnaute Barbatruc

Discussions similaires

Autres chalenge vba

XLDnaute Barbatruc

XLDnaute Barbatruc

XLDnaute Barbatruc

XLDnaute Barbatruc

XLDnaute Barbatruc

XLDnaute Barbatruc

XLDnaute Barbatruc

XLDnaute Barbatruc

XLDnaute Barbatruc

XLDnaute Nouveau

XLDnaute Nouveau

XLDnaute Barbatruc

XLDnaute Barbatruc

XLDnaute Barbatruc

XLDnaute Barbatruc

Discussions similaires

Privacy & Transparency

Privacy & Transparency