Elenco casuale

Hai un problema con Excel?

Nuova discussione

Elenco casuale
di Jellyfish (utente non iscritto) data: 25/03/2014 20:18:04
Ciao ragazzi,

devo generare un semplice elenco casuale di numeri non ripetuti da 1 a 20.000 nella prima colonna di un foglio Excel.

Ho trovato il codice che trovate allegato. Riesco a farlo funzionare per valori da 1 a 1.000 ma se supero i 1.000 mi si blocca Excel.

E' possibile ottimizzarlo per farlo arrivare a 20.000 (anche 17.000 va bene)? Non so se è rilevante ma il codice crea più elenchi diversi in base alla variabile campi, a me interessa solo un elenco.

Grazie
Jelly (iscritta ma con gravi problemi a ricordarsi le pw)

    Public Const Campi As Integer = 1       ' numero di campi da formare
    Public Const Rec As Integer = 10     ' sequenza numerica (1÷100)
    Public Riga As Integer, Valore As Integer, x As Integer, y As Integer, w As Integer


Sub Genera()
Application.ScreenUpdating = False
    For x = 1 To Campi
        Columns(x).ClearContents
        Riga = 1
        Do While Riga <= Rec
            Valore = Int((Rec * Rnd) + 1)
                For y = 1 To w
                    If Cells(y, x) = Valore Then Ok = 1
                Next y
                    If Ok = 0 Then
                        Cells(Riga, x) = Valore
                        Riga = Riga + 1
                        w = Riga
                    End If
                Ok = 0
        Loop
    Next x
Application.ScreenUpdating = True
    Range("A1").Select
End Sub

di Lucas87 data: 25/03/2014 20:41:33
Ciao.
prova questo. Guarda i commenti per impostare i valori

valmax = 20000      'valore massimo
valmin = 1          'valore minimo
ncelle = 100        'numero di celle da occupare
For i = 1 To ncelle         'scrive dalla cella 1 alla cella impostata
    a = Int(Rnd() * (valmax - valmin + 1)) + valmin
    Set fin = Columns("a").Find(what:=a, lookat:=xlWhole)
    If Not fin Is Nothing Then
        i = i - 1
    Else
        Cells(i, 1) = a
    End If
Next

di Vecchio Frac data: 25/03/2014 20:50:51
Ciao Jelly e ben ritrovata :)
Per la password prova a inviare un Modulo contatti all'Amministratore, forse lui può fare qualcosa.
Per il quesito, oltre al lavoro di Luca, ti lascio anche una mia proposta, è una funzione che restituisce una matrice, che deve essere percorsa per recuperare i valori (vedi esempio nel commento alla Function).

Function genera_lista_from_to(min As Long, max As Long) As Variant
Dim lista() As Long, i As Integer, J As Integer, r1 As Long, r2 As Long, tmp As Long
'genera una lista di numeri casuali non ripetuti nel range specificato
'esempio: u = genera_lista_from_to(1, 10): For Each k In u: Print k;: Next

    Randomize Timer
    ReDim lista(1 To max - 1) As Long
    
    'genera la lista di numeri consecutivi tra min e max
    For i = min To max - 1
        lista(i - min + 1) = i
    Next
    
    'quindi la disordina
    For i = 1 To 1000
        r1 = Int(Rnd * (max - min) + min)
        r2 = Int(Rnd * (max - min) + min)
        'swap
        tmp = lista(r1)
        lista(r1) = lista(r2)
        lista(r2) = tmp
    Next

    genera_lista_from_to = lista()

End Function

di lepat (utente non iscritto) data: 25/03/2014 21:00:20
oppure

Sub Genera()
Dim Rec As Integer, Riga As Integer, Valore As Integer, x As Integer
Application.ScreenUpdating = False
x = 1
Rec = 3000
Columns(x).ClearContents
Riga = 1
Do While Riga <= Rec
   Valore = Int((Rec * Rnd) + 1)
   If Application.WorksheetFunction.CountIf(Range(Cells(1, x), Cells(Riga, x)), Valore) = 0 Then
       Cells(Riga, x) = Valore
       Riga = Riga + 1
   End If
Loop
Application.ScreenUpdating = True
 Range("A1").Select
End Sub

di Zer0Kelvin data: 25/03/2014 21:32:50
Ciao.
La macro seguente impiega circa 12-13 secondi sul mio PC (vecchiotto) a riempire 20.000 celle.
C'è da dire che non hai specificato il valore massimo dei numeri casuali che vuoi generare.
Se vuoi utilizzare lo stesso valore per numero elementi e valore massimo, l'unica soluzione applicabile è quella di Vecchio Frac.
Tieni presente che più saranno vicini i valori di "Elementi" e "MaxValore" (ovviamente MaxValore deve essere maggiore di Elementi), più tempo impiegherà la macro a trovare i valori inutilizzati.

Option Explicit
Option Base 1

Sub ElencoCasuale()

Const Elementi = 20000
Const MaxValore = 40000
Dim Esiste As Boolean
Dim Riga As Long, i As Long, y As Long, Valore As Long, T As Single
Dim Valori(Elementi)
   
   Application.ScreenUpdating = False
   Application.EnableEvents = False
   T = Timer
   Columns(1).ClearContents
   Valori(1) = Int((MaxValore * Rnd) + 1)
   For Riga = 2 To Elementi
       Do
          Valore = Int((MaxValore * Rnd) + 1)
          Esiste = False
          For y = 1 To Riga
             If Valori(y) = Valore Then
                Esiste = True
                Exit For
             End If
          Next y
       Loop While Esiste
       Valori(Riga) = Valore
   Next Riga
   For Riga = 1 To Elementi
      Cells(Riga, 1) = Valori(Riga)
   Next Riga
   MsgBox Timer - T
   Application.EnableEvents = True
   Application.ScreenUpdating = True
End Sub

di Jellyfish (utente non iscritto) data: 25/03/2014 21:48:09
Ragazzi ho provato:

- quello di lucas87 funziona ma ci mette troppo
- quello di Vecchio Frac non riesco a farlo girare
- quello di lepat funziona ma ci mette troppo
- quello di Zer0Kelvin impiega poco ma non restituisce quanto sperato credo perché valoremax e numero elementi mi serve uguale

a questo punto come faccio a far girare quella di vecchio Frac?

di scossa data: 25/03/2014 22:13:55
@Vecchio Frac:
genera_lista_from_to(min As Long, max As Long)
poi dichiari i as integer ma gli assegni la differenza tra due long .......

Propongo un alternativa che utilizza una collection.

'---------------------------------------------------------------------------------------
' Procedure : GeneraDaA
' Author    : scossa
' Date      : 25/03/2014
' Purpose   :
'---------------------------------------------------------------------------------------
'
Public Function GeneraDaA(ByVal nMin As Long, ByVal nMax As Long) As Variant
  Dim cCasual As Collection
  Dim nCasual As Double
  Dim aCasual As Variant
  Dim j As Long
  
  Set cCasual = New Collection
  On Error Resume Next
  Do While cCasual.Count < (nMax - nMin + 1)
    nCasual = Application.WorksheetFunction.RandBetween(nMin, nMax)
    cCasual.Add nCasual, CStr(nCasual)
  Loop
  On Error GoTo 0
  ReDim aCasual(1 To cCasual.Count)
  For j = 1 To cCasual.Count
    aCasual(j) = cCasual.Item(j)
  Next j
  Set cCasual = Nothing
  GeneraDaA = aCasual
End Function


Sub prova()
  Dim aprova As Variant
  aprova = GeneraDaA(1, 20000)
  Debug.Print aprova(1)
End Sub

di scossa data: 25/03/2014 22:20:55
Se poi si vogliono mettere nel foglio:

'---------------------------------------------------------------------------------------
' Procedure : GeneraDaA
' Author    : scossa
' Date      : 25/03/2014
' Purpose   :
'---------------------------------------------------------------------------------------
'
Public Function GeneraDaA(ByVal nMin As Long, ByVal nMax As Long) As Variant
  Dim cCasual As Collection
  Dim nCasual As Double
  Dim aCasual As Variant
  Dim j As Long
  
  Set cCasual = New Collection
  On Error Resume Next
  Do While cCasual.Count < (nMax - nMin + 1)
    nCasual = Application.WorksheetFunction.RandBetween(nMin, nMax)
    cCasual.Add nCasual, CStr(nCasual)
  Loop
  On Error GoTo 0
  ReDim aCasual(1 To cCasual.Count, 1 To 1)
  For j = 1 To cCasual.Count
    aCasual(j, 1) = cCasual.Item(j)
  Next j
  Set cCasual = Nothing
  GeneraDaA = aCasual
End Function


Sub prova()
  Dim aprova As Variant
  aprova = GeneraDaA(1, 20000)
  Range("A1:A20000") = aprova
End Sub

di Jellyfish (utente non iscritto) data: 25/03/2014 22:36:33
Grazie scossa! funziona ed è velocissima mi piacerebbe capire cosa cosa fa :(

Riusciresti a commentarmi un pochino il codice?

di Zer0Kelvin data: 26/03/2014 00:00:31
Per rimanere in tema di collections...

Sub ElencoCasuale()

Const Elementi = 20000
Dim i As Long, Valore As Long, T As Single
Dim Valori(Elementi)
Dim vColl As Collection
   Application.ScreenUpdating = False
   Application.EnableEvents = False
   T = Timer
   Columns(1).ClearContents
   Set vColl = New Collection
   For i = 1 To Elementi
      vColl.Add i, CStr(i)
   Next i
   For i = 1 To Elementi
      Valore = Int((vColl.Count * Rnd) + 1)
      Cells(i, 1) = vColl(Valore)
      vColl.Remove Valore
   Next i
   MsgBox Timer - T
   Application.EnableEvents = True
   Application.ScreenUpdating = True
End Sub

PS
di Zer0Kelvin data: 26/03/2014 00:06:24
PS: piccola correzione

Sub ElencoCasuale()

Const Elementi = 20000
Dim i As Long, Valore As Long, T As Single
Dim vColl As Collection
   Application.ScreenUpdating = False
   Application.EnableEvents = False
   T = Timer
   Columns(1).ClearContents
   Set vColl = New Collection
   For i = 1 To Elementi
      vColl.Add i
   Next i
   For i = 1 To Elementi
      Valore = Int((vColl.Count * Rnd) + 1)
      Cells(i, 1) = vColl(Valore)
      vColl.Remove Valore
   Next i
   MsgBox Timer - T
   Application.EnableEvents = True
   Application.ScreenUpdating = True
   Set vColl = Nothing
End Sub

di lepat (utente non iscritto) data: 26/03/2014 08:12:39
visto che vi siete scatenati ....

Sub RandomArr()
Dim i As Integer, j As Integer, temp As Integer, arr() As Integer, first As Integer, last As Integer
T = Timer
Columns(1).ClearContents
first = 1: last = 10000
ReDim arr(last)
For i = first To last
  arr(i) = i
Next
For i = last To first Step -1
  j = Rnd * (last - first + 1) + first
  If j > last Then j = last
  temp = arr(i)
  arr(i) = arr(j)
  arr(j) = temp
Next
Range("A1:A" & last) = Application.Transpose(arr)
MsgBox Timer - T
End Sub

di lepat (utente non iscritto) data: 26/03/2014 08:15:54
scusate, ho dimenticato
option base 1
prima della sub
di ninai (utente non iscritto) data: 26/03/2014 08:36:25
Ciao a tutti
provo a farla "fuori dal vaso" anche quì:
esempio:
- in A2:A20001 mettere i numeri da 1 a 20000
- in b2:B20001 mettere =casuale()

ad ogni ordinamento (tramite icona della barra dati) della colonna B, si avrà un estrazione casuale dei numeri in A
di Mister_x (utente non iscritto) data: 26/03/2014 09:49:06
ciao

visto che vi state scatenando su tempi, e da parte mia quando si tratta di tempi la cosa si fa interessante, ho provato le tre soluzioni proposte fino ad ora e ho stilato una classifica redatta sul miglior tempo fatta su tre lanci della stessa sub() ed e' uscita questa

1° posto Lepad con 0,125005 secondi
2° posto con ZeroKelvi con 2,859375 secondi
3° posto Scossa con 11,765625 secondi

esecuzione di prova su
processore AMD 64 con 1 giga di ram

ciao

di Jellyfish (utente non iscritto) data: 26/03/2014 10:20:09

Vi siete appassionati! Grazie mille!!!

Quella di lepat è velocissima!!! ma nella prima cella mi mette uno 0 e mi salta a caso un numero :(

perché?

Inoltre l'ho personalizzata visto che il numero degli elementi dipende dai numero dei "candidati".

Non mi insultate, non so scrivere in codice purtroppo :(

Colonna A Colonna B
Ordine Casuale Candidato
3 Canditato1
4 Canditato2
29 Canditato3
33 Canditato4
45 Candidato5
... ...

Sub GeneraElencoCasuale()

Dim i As Integer, j As Integer, temp As Integer, arr() As Integer, first As Integer, last As Integer, num As Integer

num = [B1].End(xlDown).Row - 1
MsgBox ("Il numero di candidati è " & num)
  
Columns(1).ClearContents
Range("A1") = "Ordine casuale"

first = 1: last = num
ReDim arr(last)
For i = first To last
  arr(i) = i
Next
For i = last To first Step -1
  j = Rnd * (last - first + 1) + first
  If j > last Then j = last
  temp = arr(i)
  arr(i) = arr(j)
  arr(j) = temp
Next
Range(Cells(2, 1), Cells(num + 1, 1)) = Application.Transpose(arr)

Range("A1").Select
MsgBox ("Fine.")
End Sub

di lepat (utente non iscritto) data: 26/03/2014 10:56:09
devi scrivere
option base 1
prima della sub
l'ho scritto subito dopo aver postato la macro
di Jellyfish (utente non iscritto) data: 26/03/2014 11:01:26
Hai ragione scusami.

Fatto, FUNZIONA PERFETTAMENTE ed è velocissimo. Sto cercando di capire cosa fa...

Grazie mille ancora!
di lepat (utente non iscritto) data: 26/03/2014 11:05:45
Il funzionamento è semplice, prepara un array con i numeri da 1 a num, poi modifica la posizione dei vari elementi ed alla fine ricopia l'array nella colonna A
di Vecchio Frac data: 26/03/2014 12:21:36
cit. scossa: "poi dichiari i as integer ma gli assegni la differenza tra due long ....... "
---> Non capisco cosa intendi, "i" è solo un contatore e non gli assegno alcuna differenza tra long :)

@jelly
la funzione è una funzione con parametri e va utilizzata come tale :)
Avevo messo come si usa nei commenti al codice.
di scossa data: 26/03/2014 14:13:03
In:
Function genera_lista_from_to(min As Long, max As Long) As Variant

Hai dichiarato min e max come Long, poi dichiari i come Integer.

Ora se min fosse 50000 e max 60000, l'istruzione

For i = min To max - 1

genererebbe un bell'OVERLOW.

di scossa data: 26/03/2014 14:15:23
Una variante al codice di patel per evitare il problema del Transpose per matrici di oltre 64 mila elementi.
E per evitare i problemi dovuti alla stitichezza degli integer:

Sub RandomArr2()
Dim i As Long, j As Long, temp As Long, arr() As Long, first As Long
Dim last As Long, T As Single
T = Timer
Columns(1).ClearContents
first = 1: last = 60000
ReDim arr(first To last, 1 To 1)
For i = first To last
  arr(i, 1) = i
Next
For i = last To first Step -1
  j = Rnd * (last - first + 1) + first
  If j > last Then j = last
  temp = arr(i, 1)
  arr(i, 1) = arr(j, 1)
  arr(j, 1) = temp
Next
Range("C1:C" & last) = arr
MsgBox Timer - T
End Sub

di lepat (utente non iscritto) data: 26/03/2014 14:57:56
ottimo, mi sembra anche più veloce

di Zer0Kelvin data: 26/03/2014 16:23:47
Solo un piccolo "ritocco"

...........
Range("C1:C" & (last - first + 1)) = arr
...........

di Zer0Kelvin data: 26/03/2014 16:26:50
Forse si potrebbe migliorare ancora con una procedura esterna in assembler!!!
di Vecchio Frac data: 26/03/2014 17:49:57
@scossa
cit. "...genererebbe un bell'OVERLOW. "
---> Adesso ho capito, grazie per avermi corretto, modifico il mio file ^_^

Vuoi Approfondire?