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

[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 θέλουμε.

[dimitris p]

Αρχική Δημοσίευση από Tasos

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

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]

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

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

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

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

Φιλικά

Τάσος

[dimitris p]

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

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

[nisgia]

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

Η πρώτη (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]

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

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]

Αρχική Δημοσίευση από Tasos

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

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]

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

Φιλικά Τάσος

[dimitris p]

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

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

[Tasos]

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

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

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

With CreateObject("Scripting.Dictionary")

Τα λέμε..

Τάσος