Ορισμός τυχαίου αριθμού σε πεδίο πίνακα
 

Καλησπέρα σε όλους ...
Θα ήθελα τη βοήθειά σας σε ένα πρόβλημα που αντιμετωπίζω.
Έχω ένα πίνακα με ονόματα μαθητών και για κάθε όνομα υπάρχει ένα πεδίο όπου θέλω να καταχωρώ ένα τυχαίο αριθμό κλήρωσης μέσω VB αν είναι εφικτό.
Θα πρέπει αυτός ο αριθμός να είναι κυμαίνεται μεταξύ δύο τιμών (μικρότερης και μεγαλύτερης πχ 1 και 20 ή 1 και 12) και θα πρέπει να είναι διαφορετικός για κάθε μαθητή. Θα πρέπει να πω ότι το πλήθος των μαθητών θα είναι πάντα μικρότερο ή ίσο με τη μεγαλύτερη τιμή πχ. το 20 ή το 12.

Επισυνάπτω τη βάση δεδομένων προς διευκόλυνση

Ελπίζω να μη ζητώ πολλά, ευχαριστώ εκ των προτέρων...

Αγαπητε φιλε,

Δες εαν το αρχειο που σου επισυναπτω
ειναι αυτο που ζητας...

Αγαπητέ φίλε editoli (μου επιτρέπεις να σε θεωρώ φίλο και εσένα και όλους όσους ασχολούνται με την Access) ευχαριστώ για την απάντηση και το χρόνο σου.
Δεν είναι ακριβώς αυτό που θέλω για δύο λόγους
1. Δεν θα πρέπει ο αριθμός κλήρωσης να είναι δεκαδικός και
2. Αν τον αριθμό τον κάνουμε ακέραιο τότε υπάχρει περίπτωση να έχουμε τον ίδιο αριθμό δύο φορές.

Είναι σαν να θέλουμε να μοιράσουμε 12 ή 14 ή 20 νούμερα σε μαθητές χωρίς να έχουν τον ίδιο αριθμό δύο μαθητές.

Δεν ξέρω πως μπορεί να γίνει ή αν μπορεί να γίνει.

Μου πηρε λιγο χρονο αλλα νομιζω
οτι ειναι αυτο που ζητας.

Σου επισυναπτω την Βαση Δεδομενων...

Καλημέρα σε όλους!

Αγαπητέ Δημήτρη, καλωσόρισες στην παρέα μας!

Η δημιουργία τυχαίων αριθμών με όριο, επιτυνχάνεται είτε με SQL (βλ. το παράδειγμα του Τόλη), είτε με τη χρήση του αντικειμένου "Scripting.Dictionary" από τη βιβλιοθήκη Scripting Object - "scrrun.dll" (αν χρειαστεί, το βρίσκουμε εδώ: VBE> Tools> References > Microsoft Scripting Runtime).
Το αντικείμενο αυτό δεν επιτρέπει διπλοεγγραφές στους πίνακες (Array) που δημιουργεί. Αυτή ακριβώς την ιδιότητα χρησιμοποιούμε για να δημιουργήσουμε έναν πίνακα με μοναδικές τυχαίες τιμές που κατόπιν θα περαστούν στο κατάλληλο πεδίο στον πίνακα της βάσης.
Από πλευράς απόδοσης, το "Scripting.Dictionary" είναι ταχύτατο.

Δείτε ένα παράδειγμα κώδικα.
Ο κώδικας προϋποθέτει ένα πεδίο με το όνομα "LotNr".

Option Compare Database

Option Explicit



Private Sub cmdRandomize_Click()

    Dim i%, RecCount%, fld As DAO.Field, TheKeys As Variant

    With CurrentDb.OpenRecordset(Me.RecordSource, dbOpenDynaset)

        If .RecordCount Then .MoveLast: .MoveFirst

        RecCount = .RecordCount

        Set fld = .Fields("LotNr")

        On Error Resume Next

        With CreateObject("Scripting.Dictionary")

            While .Count < RecCount

                .Add Int((RecCount * Rnd) + 1), 0

            Wend

            TheKeys = .Keys

        End With

        If Err Then Err.Clear: On Error GoTo 0

        For i = 0 To RecCount - 1

            .Edit

            fld = TheKeys(i)

            .Update

            .MoveNext

        Next

        .Close

    End With

    Me.Refresh

End Sub

Τάσοοοοοοοοοοοοοοοοοοοοοο ! Το Σαββατοκύριακο τι θα κάνουμε ;
Λοιπόν !
Απαγορεύεται να γράφουν στην Access την Παρασκευή - Σάββατο - Κυριακή οι παρακάτω : Τόλης, Γιάννης, Κώστας και Τάσος!
Αστειεύομαι. Όλοι περιμένουμε τα γραψίματά τους...
Την Καλημέρα -και απο εδώ - σε όλους σας
Φιλικά / Νίκος

........Αγαπητέ μου θα χρειαστούμε αμέτρητα Σαββατοκύριακα για να καλύψουμε το Θέμα:
Office μέχρι την έκδοση 2007!
Μετά.. πάμε γι άλλα (Office 2010...):plaf:

Καλησπέρα,

Παρουσιάζω μια προσωπική μου συνάρτηση παραγωγής τυχαίων αριθμών και παίρνει απλά την Minimum (Ελάχιστη) και Maximum (Μέγιστη) τιμή.

Ενώ αν θέλουμε να την περάσουμε σε SQL ερώτημα αλλάζουμε λίγο την Randomize βάζοντας και το DumField παράμετρο
και η μία στήλη θα είναι οι τυχαίοι αριθμοί πχ η στήλη ας λέγεται (FieldRand) θα βάλουμε στην συνάρτηση και το DumField οπότε έχουμε Πχ για εύρος τυχαίων αριθμών από 10 έως 20 "Select Field1, Field2, Randomize(10,20,[Field1]) as FieldRand From Table1"

Public Function Randomize(Min, Max As Integer) As Integer

    Randomize = Int((Max - Min + 1) * Rnd + Min)

End Function



'Για SQL Ερώτημα



Public Function Randomize(Min, Max As Integer, DumField ) As Integer

    Randomize = Int((Max - Min + 1) * Rnd + Min)

End Function

Καλησπέρα σε όλους τους φίλους του forum .
Θέλω να ευχαριστήσω τον Τόλη, τον Τάσο καθώς και τον Κωσταντίνο (Kon73) που ασχολήθηκαν με το πρόβλημά μου.
Τόλη είδα τη βάση που μου έστειλες και σε ευχαριστώ για το χρόνο που αφιέρωσες υπάρχει όμως ακόμη ένα πρόβλημα.
Επισυνάπτω τη βάση που μου έστειλες με μια νέα φόρμα όπου σε εξηγώ τι θέλω να κάνω.
Αν έχεις χρόνο και όρεξη ρίξε μια ματιά όποτε μπορείς και άν μπορείς.
Αυτό ισχύει και για όποιον άλλο θα ήθελε να βοηθήσει.

Χίλια ευχαριστώ σε όλους και καλό Σαββατοκύριακο.

Φιλικά Δημήτρης

Δημήτρη έτσι:

Να επισημάνω κάτι που είναι αρκετά χρήσιμο σαν τακτική.

Για να περιορίσουμε τις λούπες στους κώδικες που είδα παρακάτω μπορούμε να ορίζουμε κάθε φορά που το Randomize βρίσκει την τιμή Min ή Μax να αλλάζει τα όρια της. Έτσι θα περιορίζονται οι τιμές. πχ Min = 1 Και Max 10 όταν βρεθεί το 1 γίνεται Min=2 έως Max 10. οπότε όταν μείνει η τιμή πχ 8 δεν θα χρειαστεί να έχουμε καμία λούπα καθότι τότε το Min με το Max θα είναι το ίδιο και βάζοντας την συνθήκη if min=max τότε μας δίνει και τον τελευταίο αριθμό άμεσα.

Την αποθήκευση θα την εφάρμοζα με ένα Array με μήκος όσο το Εύρος του Min και Max και απλά έναν έλεγχο αν υπάρχει η τιμή να προσπερνάει και να μην το αποθηκεύει.

Έτσι θα έχουμε Randomize με λιγότερες λούπες και προφανώς με όποιο Min και Max θέλουμε.

Ευχαριστώ τους φίλους του forum που έλυσαν το πρόβλημα.
Η λύση που δούλεψε καλύτερα ήταν αυτή του Τάσου.
Θα ήθελα όμως να ευχαριστήσω και τον Τόλη και τον Κωνσταντίνο που ασχολήθηκαν.
Και κάτι τελευταίο.
Στον κώδικα του Τάσου σε ποίο σημείο θα μπορούσαμε να ορίσουμε εμείς την ανώτερη τιμή (Max) που θα παίρνει.

Φιλικά Δημήτρης

Δημήτρη, η Max στην περίπτωση μας είναι η μεταβλητή "RecCount" .

Βάλε στη θέση της την τιμή που επιθυμείς.

Έδώ να πούμε ότι η συνάρτηση αυτή μπορεί να βελτιωθεί στην απόδοσή της κατά 33% περίπου (το συζητήσαμε με τον Κωνσταντίνο)
δηλαδή σε πλήθος εγγραφών μεγαλύτερο του 50.000 θα έχουμε ένα κέρδος της τάξης των 1 - 2 δευτερολέπτων.

Φιλικά

Τάσος

Τάσο έκανα την αλλαγή και είναι αυτό που ήθελα.
Και πάλι ένα μεγάλο ευχαριστώ.

Φιλικά Δημήτρης

Με την ευκαιρία να δώσω και εγώ δυο χρήσιμες ίσως συναρτήσεις.

Η πρώτη (RandomRank) μας επιστρέφει έναν πίνακα ακεραίων σε τυχαία κατάταξη
ενώ η δεύτερη (ScrambledArray) μας επιστρέφει "ανακατεμένο" τον πίνακα που της περνάμε δια αναφοράς ως παράμετρο.
Με τα ορίσματα της RandomRank καθορίζουμε το εύρος των τιμών που θέλουμε να μας επιστρέψει.

Καλημέρα!
Είχα φτιάξει κάτι παρόμοιο αλλά δεν το δημοσίευσα τελικά αφού η χρήση του
σε πολλά δεδομένα (όπου θα υπάρξει αισθητή διαφορά χρόνου εκτέλεσης) θα είναι μάλλον περιορισμένη:

Function MixArray(LngMin&, LngMax&) As Variant

    Dim i&, x#, rng&, Itm&

    ReDim xKeys(LngMin To LngMax)

    For i = LngMin To LngMax - 1

        xKeys(i) = i + 1

    Next

    rng = LngMax - LngMin

    For i = LngMin To LngMax - 1

        x = Int(Rnd * rng) + i

        Itm = xKeys(x)

        xKeys(x) = xKeys(i)

        xKeys(i) = Itm

        rng = rng - 1

    Next

    MixArray = xKeys

End Function



Sub MakeMixedArray()

    Dim MyMixedArray

    MyMixedArray = MixArray(1, 500000)

End Sub

ΠΡΟΒΛΗΜΑ με τους τυχαίους αριθμούς σε πίνακα.
 

ΠΡΟΒΛΗΜΑ με τους τυχαίους αριθμούς σε πίνακα.

Καλησπέρα σε όλους τους φίλους του forum.
Πριν από μερικές ημέρες είχα ζητήσει την βοήθειά σας για κάτι που ήθελα να κάνω.
Σαν λύση χρησιμοποίησα τον κώδικα που είχε φτιάξει ο Τάσος και όλα φαινόταν να λειτουργούν καλά.
Σήμερα που χρησιμοποίησα τη Βάση δεδομένων μου βγάζει ένα μήνυμα λάθους το οποίο δεν μπορώ να καταλάβω γιατί το βγάζει.
Επισυνάπτω τη ΒΔ και αν μπορεί κάποιος ας βοηθήσει.

Φιλικά Δημήτρης

Δημήτρη καλησπέρα!
Γράψε μας το νούμερο και την περιγραφή του μηνύματος λάθους που παίρνεις.

Φιλικά Τάσος

Τάσο το μήνυμα που παίρνω είναι:

Run-time error '457'
This key is already associated with an element of this collection

Αγαπητέ Δημήτρη καλησπέρα!

Μάλλον έχεις αφαιρέσει το : On Error Resume Next

πριν από τη γραμμή:

With CreateObject("Scripting.Dictionary")

Τα λέμε..

Τάσος

Μήνυμα λάθους
 

Τάσο επισυνάπτω τον κώδικα.
Ο κώδικας σταματά στο κίτρινο.
Έχω προσθέσει και ένα άλλο κουμπί που εκτελεί το δεύτερο κώδικα. Μήπως φταίει αυτό;

Δημήτρη, δεν έχω κατανοήσει πώς σου βγάζει το σφάλμα 457 αφού με τη γραμμή
On Error Resume Next θα αγνοηθούν τα λάθη που προκαλούνται κατά την
προσθήκη εγγραφής που ήδη έχει περαστεί.

Επειδή εκ των πραγμάτων δεν μπορώ να δω το πρόβλημα σου σε βάθος,
Θα σου συνιστούσα να τρέχεις τον παρακάτω κώδικα που δεν χρειάζεται ρουτίνα χειρισμού σφαλμάτων:

Φιλικά

Τάσος

Αγαπητέ φίλε Τάσο.
Μόλις δοκίμασα το νέο κώδικα που μου έστειλες και φαίνεται πως λειτουργεί χωρίς πρόβλημα.
Επίσης θα ήθελα να σου πω όσον αφορά τον προηγούμενο κώδικα, μήπως καταλάβεις το λόγο που έβγαζε αυτό το μήνυμα λάθους, ότι δοκίμασα την ΒΔ σε ένα άλλο υπολογιστεί που έχω και δεν μου έβγαζε αυτό το λάθος. Απλά το αναφέρω μήπως καταλάβεις τι έφταιγε.

Και πάλι ευχαριστώ
Φιλικά Δημήτρης.

Καλημέρα!
Δημήτρη, βλέποντας μόνο τον κώδικα στην εικόνα του μηνύματος σου, μπορώ να υποθέσω σε (θεωρητικό επίπεδο πάντα)
ότι για κάποιο λόγο (που εγώ "στα τυφλά" δεν μπορώ να καταλάβω) δεν διαβάστηκε και
κατά συνέπεια δεν εκτελέσθηκε η εντολή Resume next από την VBA. Γι αυτό και
εμφάνισε το σφάλμα 457.

Φιλικά

Τάσος

Καλησπέρα σε όλους τους φίλους του forum.
Επανέρχομαι στο θέμα της κλήρωσης αλλά αυτή τη φορά είναι πιο πολύπλοκο από το αρχικό.
Επισυνάπτω το αρχείο με μια νέα φόρμα (φύλο αγώνα) όπου εξηγώ τι θα ήθελα να γίνει.
Δεν ξέρω αν αυτό που ζητώ μπορεί να γίνει ή όχι αλλά σε αυτό το forum όλα είναι πιθανά.

Ευχαριστώ πολύ
Φιλικά Δημήτρης...

Δημήτρη καλημέρα!

Μέσα στο αρχείο σου γράφεις:
Απ ότι διαπίστωσα αυτό ακριβώς γίνεται ήδη στο αρχείο που ανέβασες.
Τι δεν κατάλαβα;

Φιλικά

Τάσος

Καλησπέρα Τάσο και σε όλους τους φίλους.
Καταρχάς να σε ευχαριστήσω που απάντησες στο μήνυμά μου.
Αυτό που θέλω να κάνω ή για να το θέσω καλύτερα, να το κάνεις εσύ ή κάποιος φίλος του Forum (γιατί εγώ αποκλείεται να το κάνω), το περιγράφω στην δεύτερη φόρμα που υπάρχει στο επισυναπτόμενο αρχείο. Είναι συνέχεια του πρώτου αρχείου που όπως σωστά λες γίνεται, αλλά με άλλες δύο παραμέτρους που περιγράφω στην δεύτερη φόρμα "Φύλο Αγώνα". Θα πρέπει δηλαδή ή κλήρωση να μπορεί να λάβει υπόψιν τις 3 περιπτώσεις που περιγράφω.
Την πρώτη περίπτωση την έχεις καλύψει με τον πρώτο κώδικα που είχες στείλει, τώρα αν μπορεί να καλυφθεί ή δεύτερη περίπτωση θα ήταν πολύ καλό, και όσον αφορά την τρίτη περίπτωση που λογικά είναι ή δυσκολότερη αν γίνεται καλώς αλλιώς θα το κάνω χειροκίνητα μετά την κλήρωση.

Δεν ξέρω αν σου έδωσα να καταλάβεις τι πρέπει να γίνει.

Φιλικά Δημήτρης...