[Excel 2010]Casuale... ma ordinato

[recalcatiiti]

Buongiorno a tutti,

supponiamo che io abbia 3 (o più) gruppi da quattro (o più) celle adiacenti ciascuno. Ogni cella di ogni gruppo contiene un carattere. Ogni gruppo contiene caratteri di un solo tipo e con un determinato ordine.

Esempio:

Quello che vorrei ottenere, anche tramite una macro, è un'unica stringa formata dalla totalità dei caratteri contenuti nei gruppi, in cui la sola posizione reciproca dei caratteri di ogni gruppo è random ma il loro ordine rimane invariato.

Esempio:

Infatti leggendo da sinistra a destra la stringa nella seconda immagine possiamo leggere: 1_2____3__4_ - _A__B___C__D oppure ___cuori_quadri fiori__picche__

Qualcuna ha qualche idea?

Vi ringrazio TUTTI anticipatamente,

sr

[wallace&gromit]

assumendo che i tuoi dati da mescolare siano nelle celle da A1 a D3 ho elaborato questa macro.
Sicuramente non molto valida dal punto estetico (qualche guru delle macro mi bacchetterà) però sembra funzionare.

Ho preparato prima una versione con una virgola di separazione, ma poi l'ho tolta (vedi tu se preferisci averla o no)

Codice: Seleziona tutto

Sub CasualeGruppi()
Lista = ""
i = 1
k = 1
l = 1
m = 1
Massimo = 3
Minimo = 1
Do While i < 13

riprova:
Randomize (Timer)
Pesca = Int((Massimo - 1 + Minimo) * Rnd + Minimo)
Select Case Pesca
Case 1
If k < 5 Then
Lista = Lista & Cells(Pesca, k) ' & ","
k = k + 1
GoTo prossimo
End If

Case 2
If l < 5 Then
Lista = Lista & Cells(Pesca, l) ' & ","
l = l + 1
GoTo prossimo
End If

Case 3
If m < 5 Then
Lista = Lista & Cells(Pesca, m) ' & ","
m = m + 1
GoTo prossimo
End If

End Select

GoTo riprova

prossimo:
i = i + 1
Loop
'Range("F2") = Left(Lista, Len(Lista) - 1)
Range("F2") = Lista

End Sub


[Anthony47]

Io temo che ci sia un problema di risultato, non di eleganza del codice (una macro che produce il risultato atteso e' sempre perfetta), giacche' probabilmente quei disegni sono ottenuti con una formattazione particolare della cella.
Pertanto aggiungo la mia proposta:

Codice: Seleziona tutto

Sub peppap()
Dim maxI As Long, maxJ As Long, I As Long, J As Long, myRes As Range, myRan As Range
Dim myFont() As String, myRND As Long, fillX As Long, myOut As String
'
Set myRan = Range("A1:D4")      '<<< L'area con i valori
Set myRes = Range("G1")         '<<< La cella con l'esito
'
fillX = 9
ReDim myFont(1 To myRan.Count)
Randomize
maxI = myRan.Rows.Count
maxJ = myRan.Columns.Count
reSt:
myOut = String(myRan.Count, Chr(fillX))
For I = 1 To maxI - 1
dlock = 0: oldrnd = 0
    For J = 1 To maxJ
reRand:
DoEvents
        dlock = dlock + 1
        If dlock > 30 Then
            GoTo reSt
        End If
        myRND = Int((myRan.Count) * Rnd + 1): If (J + 1) = 2 Then myRND = Int(myRND / maxI) + 1
        If Mid(myOut, myRND, 1) = Chr(fillX) And myRND > oldrnd Then
            myOut = Left(myOut, myRND - 1) & myRan.Cells(I, J) & Mid(myOut, myRND + 1, 999)
            myFont(myRND) = myRan.Cells(I, J).Font.Name
            oldrnd = myRND
        Else
            GoTo reRand
        End If
    Next J
Next I
'myRes = myOut
'set last line:
J = 1
For I = 1 To myRan.Count
    If Mid(myOut, I, 1) = Chr(fillX) Then
        myOut = Left(myOut, I - 1) & Left(myRan.Cells(maxI, J) & " ", 1) & Mid(myOut, I + 1, 999)
         myFont(I) = myRan.Cells(maxI, J).Font.Name
        J = J + 1
    End If
Next I
myRes = myOut
'Set font:
For I = 1 To myRan.Count
    myRes.Characters(I, 1).Font.Name = myFont(I)
Next I
'SOLO PER Test:
'mymatch = Application.Match(Left(myOut, 1), Range("A1:A10"), 0)
'Cells(mymatch, "M") = Cells(mymatch, "M") + 1
End Sub


Le righe marcate <<< vanno personalizzate con le informazioni circa la dimensione dell'area sorgente e la cella del risultato.

Ciao

Edit: Le istruzioni in coda erano solo per il mio test, le ho "commentate" ma possono essere eliminate
Anthony

[scossa]

Ciao,

una possibile alternativa:

Codice: Seleziona tutto

'---------------------------------------------------------------------------------------
' Procedure : Mescola
' Author    : scossa
' Date      : 17/06/2016
' Purpose   :
'---------------------------------------------------------------------------------------
'
Public Sub Mescola()

  Dim wb As Workbook
  Dim ws As Worksheet
  Dim rngCUT As Range
  Dim rngRet As Range
  Dim aVUT As Variant
  Dim vSymb As Variant
  Dim bLoop As Boolean
  Dim nLoop As Long
  Dim i As Long, j As Long, k As Long, x As Long, n As Long
  Dim cCol As Collection
  Dim nErr As Long
   
  On Error GoTo Mescola_Error
  With Application
    .StatusBar = "elbaorazione in corso ...."
    .ScreenUpdating = False
  End With
   
  Set wb = ThisWorkbook
  Set ws = wb.ActiveSheet
  Set cCol = New Collection
  Set rngCUT = ws.Range("B2:E4") ' cambiare a coerenza con la posizione reale della tabella
 
  aVUT = rngCUT
  j = UBound(aVUT, 1)
  k = UBound(aVUT, 2)
  n = 0
  For x = 1 To k
    bLoop = True
    nLoop = 1
    Do While nLoop <= j
      i = RndBtwn(1, j)
      vSymb = aVUT(i, x)
      On Error Resume Next
      cCol.Add vSymb, CStr(vSymb)
      nErr = Err.Number
      On Error GoTo Mescola_Error
      If nErr = 0 Then
       n = n + 1
        With ws
         rngCUT.Cells(i, x).Copy .Cells(10, n + 1) 'cambiare 10 (riga) e +1 (colonna)in base a dove vuoi l'output
        End With
       nLoop = nLoop + 1
      End If
      Err.Clear
    Loop
  Next x
  On Error GoTo 0

Mescola_Error:

  Set rngCUT = Nothing
  Set rngRet = Nothing
  Set cCol = Nothing
  Set ws = Nothing
  Set wb = Nothing
 
  With Application
    .StatusBar = False
    .ScreenUpdating = True
  End With
 
  If Err.Number <> 0 Then
    MsgBox "Error: " & Err.Description, vbCritical, "ERRORE"
  End If
End Sub


'---------------------------------------------------------------------------------------
' Procedure : RndBtwn
' Author    : scossa
' Date      : 17/06/2016
' Purpose   :
'---------------------------------------------------------------------------------------
'
Private Function RndBtwn(ByVal nLwr As Long, ByVal nUpr As Long) As Long

  Randomize
  RndBtwn = Int((nUpr - nLwr + 1) * Rnd + nLwr)

End Function

nel codice ho presupposto la tabella dei simboli in B2:F5 e il risultato in riga 10 dalla colonna B in poi.

[scossa]

nel codice ho presupposto la tabella dei simboli in B2:F5 e il risultato in riga 10 dalla colonna B in poi.

errata:
nel codice ho presupposto la tabella dei simboli in B2:F5 ....
corrige:
nel codice ho presupposto la tabella dei simboli in B2:E4 ....

[Anthony47]

Scossa, non so se sbaglio qualcosa ma la tua macro mi va in errore; in particolare:
-provata con 2 righe di dati, funziona sempre
-provata con 3 o piu' righe, va in loop dopo aver posizionato tutti-1 elementi
Il file di prova e' questo: https://www.dropbox.com/s/ci60jt0iwd93h ... .xlsm?dl=0
I dati per il test sono in Foglio1; la tua macro e' in Modulo3. Le righe marcate **** sono state aggiunte o modificate da me ad uso test.

Mi sono accorto che nella mia Sub peppap sono rimaste due righe (finali) che mi servivano per i test; queste righe in condizioni normali vanno invece in errore.
Ho modificato il codice nel messaggio originale (post del 17/6 "mattina presto")

Ciao a tutti.

[scossa]

Ciao Anthony,

Scossa, non so se sbaglio qualcosa ma la tua macro mi va in errore; in particolare:
-provata con 2 righe di dati, funziona sempre
-provata con 3 o piu' righe, va in loop dopo aver posizionato tutti-1 elementi

Vero, non avevo considerato che la chiave di una collection non distingue tra maiuscole e minuscole. Nel tuo file c'è sia la lettera D che d, quindi va in loop.

Si può risolvere semplicemente modificando

Codice: Seleziona tutto

cCol.Add vSymb, CStr(vSymb)

in

Codice: Seleziona tutto

cCol.Add vSymb, CStr(vSymb) & i & x

o addirittura in

Codice: Seleziona tutto

cCol.Add vSymb, i & x

[recalcatiiti]

Ciao a tutti ragazzi,

rispondo molto velocemente con un grazie!
Ho provato le macro tranne quella di scossa (provvedo stasera).
Funziona correttamente quella di Anthony, ho notato una cosa però. quando un gruppo contiene n>7 caratteri, i tempi di calcolo si dilatano enormemente... per darvi un idea, dovrei lavorare con gruppi contenenti n>60 (sessanta) caratteri... si può fare qualcosa?

vi ringrazio tanto comunque, siete preziosi

ciao a presto.

[Anthony47]

Se hai molte piu' Colonne (ma anche Righe) allora dovremmo cercare un algoritmo meno prestante per quanto riguarda la capacita' di randomizzare le posizioni.
Ad esempio questo codice, da inserire in un Modulo a se stante:

Codice: Seleziona tutto

Dim mySeq() As Long
Sub peppa10()
'random a livello di singolo blocco
Dim maxI As Long, maxJ As Long, I As Long, J As Long, myRes As Range, myRan As Range
Dim myFont() As String, fillX As Long, myOut As String
Dim myInd As Long
'
Set myRan = Range("A1:H8")      '<<< L'area con i valori
Set myRes = Range("Q1")         '<<< La cella con l'esito
'
fillX = 32
ReDim myFont(1 To myRan.Count)
Randomize
maxI = myRan.Rows.Count
maxJ = myRan.Columns.Count
ReDim mySeq(1 To maxI)
myOut = String(myRan.Count, Chr(fillX))
'
For J = 1 To maxJ
    Call SetSeq(maxI)
    For I = 1 To maxI
DoEvents
        myInd = myInd + 1
        myOut = Left(myOut, myInd - 1) & myRan.Cells(mySeq(I) + 1, J) & Mid(myOut, myInd + 1, 999)
        myFont(myInd) = myRan.Cells(mySeq(I) + 1, J).Font.Name
    Next I
    myRes = myOut
Next J
myRes = myOut
'Set font:
For I = 1 To myRan.Count
    myRes.Characters(I, 1).Font.Name = myFont(I)
Next I
End Sub

Sub SetSeq(ByVal iMAx As Long)
Dim LI As Long, LJ As Long, Rnk As Long, mYArr()
'
ReDim mYArr(1 To iMAx)
For LI = 1 To iMAx
    mYArr(LI) = Rnd
Next LI
For LI = 1 To iMAx
Rnk = 0
    For LJ = 1 To iMAx
        If mYArr(LI) > mYArr(LJ) Then Rnk = Rnk + 1
    Next LJ
mySeq(LI) = Rnk
Next LI
End Sub


La macro da eseguire e' Sub peppa10.
Questa fa una randomizzazione blocco per blocco ed e' (ragionevolmente) insensibile alla dimensione dell'area da mescolare.
Il file gia' pubblicato su dropbox e' aggiornato con questo codice (vedasi Modulo5)

Ciao

[recalcatiiti]

Questa risponde perfettamente al quesito Anthony, è paurosamente esatta, quindi si può considerare risolto.
ma, c'è un fatidico "ma".
Ho notato come peppa10, a differenza di peppap, limita l'utilizzo del particolare set di caratteri in uso.(giustamente, in quanto il quesito è stato così posto).
Mi spiego meglio. Consideriamo uno dei gruppi che ho utilizzato nell'esempio, i numeri naturali.
con essi peppa10 funziona bene, ma se volessi estendere la sequenza anche ai numeri negativi, non funziona. Ragionevolmente, in quanto un numero negativo è formato da due caratteri mentre peppa10 prende solo il primo.
Stessa questione si potrebbe applicare ad altri "set", come ad esempio il simbolo degli elementi chimici... Potrei usare H, C, S ma non Cr, Fe o Zn

Consapevole del fatto che questa obbiezione esula dal quesito proposto e ringraziandovi tanto per quello che avete fatto fino ad ora, vi chiedo se ci sia un modo per ovviare a questo problema, utilizzando una macro in grado di elaborare molte colonne (e molto meno righe, spero sia un dato che vi possa servire) in un tempo ragionevole.

Ciao e a presto

sr

[Anthony47]

La mia penultima variante e' in Modulo5 del file disponibile su Dropbox; la macro da lanciare e' peppa11.
E' molto tollerante sul contenuto delle celle.
Il codice completo, da essere inserito in un Modulo a se riservato (come doveva avvenire gia' con peppa10), e':

Codice: Seleziona tutto

Dim mySeq() As Long, myPepp()
Sub peppa11()
'random a livello di singolo blocco, celle multicarattere
Dim maxI As Long, maxJ As Long, I As Long, J As Long, myRes As Range, myRan As Range
Dim myFont() As String
Dim myInd As Long, myPippo As Long
'
Set myRan = Range("A1:H4")      '<<< L'area con i valori
Set myRes = Range("Q1")         '<<< La cella con l'esito
myRes.Clear
'
'fillX = 32
Randomize
maxI = myRan.Rows.Count
maxJ = myRan.Columns.Count
ReDim mySeq(1 To maxI)
ReDim myPepp(1 To myRan.Count, 1 To 2)  'x , y
'
For J = 1 To maxJ
    Call SetSeq(maxI)
    For I = 1 To maxI
DoEvents
        myInd = myInd + 1
        myPippo = myPippo + Len(myRan.Cells(I, J))
        myPepp(myInd, 1) = mySeq(I) + 1
        myPepp(myInd, 2) = J
    Next I
Next J
ReDim myFont(1 To myPippo)
myPippo = 0
For I = 1 To myRan.Count
DoEvents
    For J = 1 To Len(myRan.Cells(myPepp(I, 1), myPepp(I, 2)).Value)
        myPippo = myPippo + 1
        myRes = myRes.Value & Mid(myRan.Cells(myPepp(I, 1), myPepp(I, 2)).Value, J, 1)
        myFont(myPippo) = myRan.Cells(myPepp(I, 1), myPepp(I, 2)).Characters(J, 1).Font.Name
    Next J
Next I
'Set font:
For I = 1 To UBound(myFont)
    myRes.Characters(I, 1).Font.Name = myFont(I)
Next I
End Sub



Sub SetSeq(ByVal iMAx As Long)
Dim LI As Long, LJ As Long, Rnk As Long, mYArr()
'
ReDim mYArr(1 To iMAx)
For LI = 1 To iMAx
    mYArr(LI) = Rnd
Next LI
For LI = 1 To iMAx
Rnk = 0
    For LJ = 1 To iMAx
        If mYArr(LI) > mYArr(LJ) Then Rnk = Rnk + 1
    Next LJ
mySeq(LI) = Rnk
Next LI
End Sub


Ciao

[recalcatiiti]

Anthony, eccellente... come al solito,
A scopo didattico volevo chiederti cosa intendessi per

allora dovremmo cercare un algoritmo meno prestante per quanto riguarda la capacita' di randomizzare le posizioni.

grazie e a presto

sr

[Anthony47]

Quella frase era una meditazione personale...
La prima soluzione randomizzava in modo incontrollato le stringhe (d'altra parte Random vuol dire Casuale), ma poi bisognava ripetere tutto quando la macro si accorgeva che le regole non erano rispettate, con tempi che si allungavano esponenzialmente.
La nuova macro si limita a mettere in sequenza random tutte le prime lettere, poi tutte le seconde, poi tutte le terze, e cosi' via fino alla fine.
Ad esempio, con 4 gruppi da 3 crt:

Codice: Seleziona tutto

1 2 3
a b c
A B C
! * +

La prima macro (peppap) avrebbe potuto posizionare cosi':

Codice: Seleziona tutto

A 1 2 ! 3 B a * b c + C

L'ultima (peppa11) invece:

Codice: Seleziona tutto

A a ! 1 - 2 B c * - + c C 3

(i trattini sono messi solo per evidenziare i 3 blocchi in cui vengono mescolati i caratteri di tutti i gruppi).

Ciao

[recalcatiiti]

Molto chiaro.
Questo però significa che peppa11 non può generare tutte le combinazioni randomizzate che genera peppap. Ciò coincide perfettamente con il tuo <<meno prestante>> quotato prima. Ti ringrazio
Ciao