Ordine casuale

Hai un problema con Excel?

Nuova discussione

Ordine casuale
di bcgeppo data: 17/05/2014 14:39:23
Buongiorno forum, premetto che ho letto gia qualcosa del genere, io ci ho provato a ricercarlo ma proprio non riesco a trovarlo, comunque vi pongo il problema a cui sono a chiedere aiuto:
ho 40 numeri uno per cella (dalla A1 alla A40) e associando un pulsante con una macro ordinare questi 40 numeri in maniera casuale in modo da generare un codice sempre diverso.
grazie e buon Sabato a tutti

di Vecchio Frac data: 17/05/2014 15:06:12
Ti mostro una possibile soluzione.
L'esempio è ritagliato apposta sulle condizioni di partenza (foglio attivo, colonna A, numeri univoci non ripetuti da 1 a 40 nelle celle da A1 a A40).
Ovviamente si può parametrizzare e generalizzare, cosa che sarebbe più sensata, ma il concetto è "estrai a caso due celle, scambia fra loro il contenuto, e ripeti l'operazione mille volte, per assicurare una certa casualità".

Option Explicit

Sub mescola_range()
Dim r As Range, i As Integer
Dim r1 As Integer, r2 As Integer, tmp As Integer

    Randomize Timer

    Set r = Range("A1:A40")

    For i = 1 To 1000       'numero di estrazioni
        r1 = Int(Rnd * 40) + 1
        r2 = Int(Rnd * 40) + 1
        
        'swap celle
        tmp = Cells(r1, "A")
        Cells(r1, "A") = Cells(r2, "A")
        Cells(r2, "A") = tmp
    Next
End Sub

di lepat (utente non iscritto) data: 17/05/2014 16:19:13
oppure

Sub RandomRange()
Dim i As Integer, j As Integer, temp As Integer, arr(), first As Integer, last As Integer
arr = Range("A1:A40").Value
last = UBound(arr)
first = 1
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("A1:A40") = Application.Transpose(Application.Transpose(arr))
End Sub

di scossa data: 17/05/2014 16:52:03
O ancora:

Public Sub Casual40()
  Dim cDict40 As Object, nRand As Integer, aRng As Variant
  Set cDict40 = CreateObject("Scripting.Dictionary")
  With Application
    Do While cDict40.Count < 40
      nRand = .RandBetween(1, 40)
      cDict40(nRand) = cDict40(nRand)
    Loop
    aRng = cDict40.Keys
    Range("A1:A40") = .Transpose(aRng)
  End With
  Set cDict40 = Nothing
End Sub

scossa's web site

Se tu hai una mela, ed io ho una mela, e ce le scambiamo, allora tu ed io abbiamo sempre una mela per uno.
Ma se tu hai un'idea, ed io ho un'idea, e ce le scambiamo, allora abbiamo entrambi due idee. (George Bernard Shaw)

di bcgeppo data: 17/05/2014 18:58:50
Tutti perfetti, grazie 1K

Vuoi Approfondire?