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

Σελίδα 2 από 3

Εμφάνιση 40 μηνυμάτων αυτού του θέματος σε μία σελίδα

Forum (https://www.ms-office.gr/forum/)

- Access - Ερωτήσεις / Απαντήσεις (https://www.ms-office.gr/forum/access-erotiseis-apantiseis/)

- - [ Πίνακες ] Ορισμός τυχαίου αριθμού σε πεδίο πίνακα (https://www.ms-office.gr/forum/access-erotiseis-apantiseis/450-orismos-tyxaioy-arithmoi-se-pedio-pinaka.html)

kon73

26-02-10 23:14

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

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

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

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

dimitris p

27-02-10 12:42

Παράθεση:

Αρχική Δημοσίευση από Tasos (Μήνυμα 1918)

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

Κώδικας:

Private Sub Εντολή11_Click()

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

    strSQL = "Select * From " & Me.RecordSource & IIf(Me.FilterOn, " Where " & Me.Filter, vbNullString)

    With CurrentDb.OpenRecordset(strSQL, dbOpenDynaset)

    

        If .RecordCount Then .MoveLast: .MoveFirst

        RecCount = .RecordCount

        Set fld = .Fields("ΑρΚλήρωσης")

        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

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

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

Tasos

27-02-10 14:00

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

Κώδικας:

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

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

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

Φιλικά

Τάσος

dimitris p

27-02-10 16:45

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

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

nisgia

05-03-10 02:31

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

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

Κώδικας:

Function RandomRank(ByVal lngMax As Long, _

        Optional ByVal lngMin As Long = 1) As Long()

    'Δημιουργία πίνακα με τυχαία κατάταξη

    Dim alngArray() As Long

    Dim lngPos As Long

    Dim lngTemp As Long

    Dim i As Long



    ReDim alngArray(lngMin To lngMax)

    For i = lngMin To lngMax

        alngArray(i) = i

    Next i



    For i = lngMax To (lngMin + 1) Step -1

        lngPos = Int((i - lngMin + 1) * Rnd + lngMin)

        lngTemp = alngArray(lngPos)

        alngArray(lngPos) = alngArray(i)

        alngArray(i) = lngTemp

    Next i

    RandomRank = alngArray()

End Function



Function ScrambledArray(varArray As Variant) As Boolean

    'Τυχαίο ανακάτεμα του πίνακα varArray 

    Dim i As Long

    Dim lngUB As Long

    Dim lngLB As Long

    Dim lngPos As Long

    Dim varTemp As Variant

    

    If IsArray(varArray) Then

        lngUB = UBound(varArray)

        lngLB = LBound(varArray)

        For i = lngUB To lngLB + 1 Step -1

            lngPos = Int((i - lngLB + 1) * Rnd + lngLB)

            varTemp = varArray(lngPos)

            varArray(lngPos) = varArray(i)

            varArray(i) = varTemp

        Next i

        ScrambledArray = lngUB > lngLB

    End If

End Function

Tasos

05-03-10 13:12

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



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

dimitris p

09-03-10 17:22

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

1 Συνημμένο(α)

Παράθεση:

Αρχική Δημοσίευση από Tasos (Μήνυμα 2005)



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.
Πριν από μερικές ημέρες είχα ζητήσει την βοήθειά σας για κάτι που ήθελα να κάνω.
Σαν λύση χρησιμοποίησα τον κώδικα που είχε φτιάξει ο Τάσος και όλα φαινόταν να λειτουργούν καλά.
Σήμερα που χρησιμοποίησα τη Βάση δεδομένων μου βγάζει ένα μήνυμα λάθους το οποίο δεν μπορώ να καταλάβω γιατί το βγάζει.
Επισυνάπτω τη ΒΔ και αν μπορεί κάποιος ας βοηθήσει.

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

Tasos

09-03-10 17:59

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

Φιλικά Τάσος

dimitris p

09-03-10 21:10

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

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

Tasos

09-03-10 21:21

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

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

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

With CreateObject("Scripting.Dictionary")

Τα λέμε..

Τάσος

Η ώρα είναι 09:01.

Σελίδα 2 από 3

Εμφάνιση 40 μηνυμάτων αυτού του θέματος σε μία σελίδα

Search Engine Optimization by vBSEO 3.3.2