vba excel vincoli x rotazione

[macio66]

Buonasera

http://www.filedropper.com/rotazione

Nel file di esempio che ho riportato, premendo il pulsante "Rotazione", avvia un ciclo dove ogni nominativo, deve essere presente una sola volta nella posizione 1, una sola volta nella posizione 2 e una sola volta nella posizione 3. (nell' esempio, al posto dei nominativi, ho inserito delle lettere)
Fin quì tutto bene (grazie al vostro aiuto in una altro topic).
Ora volevo inserire dei vincoli (parte aggiunta da me nel codice)
'
LR = Cells(Rows.Count, "B").End(xlUp).Row
'
For r = 1 To LR
'
If Cells(r, 2) = Cells(r, 6) Or Cells(r, 3) = Cells(r, 7) Then

In pratica la rotazione dovrebbe tenere conto della classe della postazione, che non deve essere uguale a quella della persona (colonna "B" con colonna "F") e delle limitazioni (colonna "C" con colonna "G"), anche in questo caso non devono essere uguali.
Ma al completamento della rotazione, alcune righe non rispettano i vincoli da me impostati.
In cosa sto sbagliando?
Grazie

[macio66]

Nel codice VBA, avevo inserito un controllo che in caso di errore, mi avvisasse con un messaggio.
Il messaggio appare, ma quando clicco su OK, invece di terminare la macro, continua a visualizzarmi il messaggio per parecchie volte (infatti devo tenere premuto Esc per un bel po).
SOS

[Anthony47]

Mi e' venuto mal di testa a cercare di capire il significato della macro.
Ti butto questa modifica, vedi se nei risultati fa quello che chiedi:

Codice: Seleziona tutto

Sub random31()
'
'On Error GoTo Errore
'
''LR = Cells(Rows.Count, "B").End(xlUp).Row
'
''For r = 1 To LR
'
''If Cells(r, 2) = Cells(r, 6) Or Cells(r, 3) = Cells(r, 7) Then
'
ripetI1:
CC2 = 0
first = 1: last = 30
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
reJ1:
    j = Rnd * (last - first + 1) + first
    If j > last Then j = last
    temp = arr(i, 1)
    If Cells(arr(i, 1), "B") <> Cells(arr(j, 1), "F") And Cells(arr(i, 1), "C") <> Cells(arr(j, 1), "G") Then
      arr(i, 1) = arr(j, 1)
      arr(j, 1) = temp
    Else
    DoEvents
        GoTo reJ1
    End If
Next
Worksheets("Foglio1").Range("K1:K" & (last - first + 1)) = arr

ripetI2:
Cc3 = 0
first = 1: last = 30
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
reJ2:
  j = Rnd * (last - first + 1) + first
  If j > last Then j = last
  temp = arr(i, 1)
    If Cells(arr(i, 1), "B") <> Cells(arr(j, 1), "F") And Cells(arr(i, 1), "C") <> Cells(arr(j, 1), "G") Then

      arr(i, 1) = arr(j, 1)
      arr(j, 1) = temp
    Else
    DoEvents
        GoTo reJ2
    End If
Next
Worksheets("Foglio1").Range("L1:L" & (last - first + 1)) = arr
For i = 1 To 30
DoEvents
    If Cells(i, 12) = Cells(i, 11) Then
        CC2 = CC2 + 1
        If CC2 > 10 Then
        Debug.Print "Loop 2>1"
            GoTo ripetI1
        Else
        Debug.Print "Loop 2"
            GoTo ripetI2
        End If
    End If
Next

ripeti3:
DoEvents
first = 1: last = 30
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
rej3:
  j = Rnd * (last - first + 1) + first
  If j > last Then j = last
  temp = arr(i, 1)
    If Cells(arr(i, 1), "B") <> Cells(arr(j, 1), "F") And Cells(arr(i, 1), "C") <> Cells(arr(j, 1), "G") Then
      arr(i, 1) = arr(j, 1)
      arr(j, 1) = temp
    Else
    DoEvents
        GoTo rej3
    End If
Next
Worksheets("Foglio1").Range("M1:M" & (last - first + 1)) = arr
For i = 1 To 30
DoEvents
    If Cells(i, 13) = Cells(i, 11) Or Cells(i, 13) = Cells(i, 12) Then
        Cc3 = Cc3 + 1
        If Cc3 > 10 Then
            Debug.Print "Loop 3>2"
            GoTo ripetI2
        Else
        Debug.Print "Loop 3"
            GoTo ripeti3
        End If
    End If
Next

For j = 1 To 30
    For k = 1 To 3
        Cells(k + (Cells(j, 10 + k) + 0) * 3, 5) = Cells(j, 10)
    Next k
Next j
'
''End If
''Next r
'
'Errore: MsgBox "Nomi non compatibili con la rotazione", vbInformation
'
'Exit Sub
'
End Sub


Ciao

[macio66]

Ciao Anthony
Innanzitutto ti ringrazio x il tuo interessamento (anche se per questo ti è venuto il mal di testa). Lo so di essere un casinaro.
Ho provato la macro da te modificata, ma anche in questo caso, la macro termina prima di aver soddisfatto i vincoli.
Infatti in alcune righe il testo della colonna B e uguale a quello della colonna F, e in altre il testo della colonna C e uguale a quello della colonna G. Mentre il risultato che mi aspetto. e che siano tutte diverse, continuando a garantire un solo inserimento per ogni numero del nome (ma per questo direi che funziona).

[Anthony47]

Credo di aver capito quali sono i dati di partenza e come e' organizzato il file.

La seguente macro compila la colonna E di Foglio1, e usa le formule presenti in F e G per gestire le eccezioni:

Codice: Seleziona tutto

Sub RivangaXX()
Dim f2Arr, F1St As String, Cas As Long, R3Pos As Range, RCPos As Range
Dim LB0 As Long, UB0 As Long, cItm As Long, cCnt As Long, clErr As Boolean, gErr As Boolean
Dim I As Long, J As Long, oCC As Long, oCC1 As Long, myTim As Single
'
Sheets("Foglio1").Select
f2Arr = Range(Sheets("Foglio2").Range("A2"), Sheets("Foglio2").Cells(Rows.Count, 1).End(xlUp)).Value
aaa = UBound(f2Arr)
LB0 = LBound(f2Arr)
UB0 = UBound(f2Arr)
cItm = UB0 - LB0 + 1
F1St = "A4"
Set R3Pos = Range(F1St).Resize(cItm * 3, 1)
'
reAll:
For I = 0 To 2
reI:
f2Arr = Range(Sheets("Foglio2").Range("A2"), Sheets("Foglio2").Cells(Rows.Count, 1).End(xlUp)).Value
myTim = Timer
    Range(F1St).Range("E" & (I * cItm + 1)).Resize(cItm * (3 - I), 1).ClearContents
    cCnt = 0
    For J = 1 To cItm
        Set RCPos = Range(F1St).Range("A" & (I * cItm + 1)).Resize(cItm, 1)
reJ:
DoEvents
        Cas = Int(Rnd() * UB0) + LB0
        If f2Arr(Cas, 1) = "" Then GoTo reJ
        Range(F1St).Range("E" & (I * cItm + J - 0)) = f2Arr(Cas, 1)
        oCC = Evaluate("sum(--(" & RCPos.Range("E1:E" & cItm).Address & "=""" & f2Arr(Cas, 1) & """))")
        oCC1 = Evaluate("sum(--((" & R3Pos.Offset(0, 3).Address & "&" & R3Pos.Offset(0, 4).Address & ")=(""" & Range(F1St).Range("D" & (I * cItm + J)).Value & f2Arr(Cas, 1) & """)))")
        If Range(F1St).Range("B" & (I * cItm + J - 0)) = Range(F1St).Range("F" & (I * cItm + J - 0)) Then clErr = True Else clErr = False
        If Range(F1St).Range("C" & (I * cItm + J - 0)) = Range(F1St).Range("G" & (I * cItm + J - 0)) Then gErr = True Else gErr = False
        If (oCC + oCC1) > 2 Or clErr Or gErr Then
            DoEvents
            If (Timer - myTim) > 15 Or Timer < myTim Then GoTo reAll
            cCnt = cCnt + 1
            If cCnt > 30 Then
                If I > 0 Then
                    Debug.Print "Loop <1", I
                    I = I - 1
                    GoTo reI
                Else
                    Debug.Print "Loop 0>0", I
                    GoTo reI
                End If
            Else
                Debug.Print "Loop =", I
                GoTo reJ
            End If
        Else
            cCnt = 0
        End If
''    If [P1] > (I + 1) Then Stop
    f2Arr(Cas, 1) = ""
    Next J
Next I
MsgBox ("Completato...")
End Sub


La macro lavora solo "di forza", estraendo uno dei nominativi presenti e verificando se i vincoli sono rispettati; se No prova un nuovo estratto. Periodicamente si torna alla "postazione" precedente per superare eventuali incagli.
Non e' detto che il risultato sia trovato; se dopo 5 minuti e' ancora in esecuzione si puo' interrompere con la combinazione Contr / Pausa Interruz e provare con vincoli meno stringenti.
I nominativi non possono cominciare con un Numero.

Ciao

[macio66]

Ciao Anthony
La macro funziona come speravo.
Sto facendo un po di fatica a capirla e per questo ti chiedo, se mi puoi dare delle dritte.
Adesso lavora su tre postazioni che hanno in tutto 30 rotazioni. Ma se volessi aggiungere un postazione con altre 4 rotazioni, cosa devo variare nel codice?
E se invece volessi togliere una postazione, devo variare qualcosa o posso lasciarla cosi come è?
Grazie

[Anthony47]

Se vuoi piu' postazioni allora e' meglio che modifichiamo questa parte della macro:

Codice: Seleziona tutto

cItm = UB0 - LB0 + 1
F1St = "A4"             '<<< L'inizio della prima tabella
postaZ = 3              '<<<2 N° di "postazioni"
'
Set R3Pos = Range(F1St).Resize(cItm * postaZ, 1)
reAll:
For I = 0 To (postaZ - 1)
reI:


La prima e l'ultima riga sono gia' presenti, le modifiche sono nelle righe intermedie.
Per modificare le postazioni va modificata la riga marcata <<<2.
Le colonne D (valori) e le formule in F e G devono essere inseriti prima di avviare la macro, altrimenti il completamento delle assegnazioni potrebbe essere errato o impossibile.

Il numero di voci per ogni postazione deve essere pari all'altezza della tabella di Foglio2.

Ciao

[Anthony47]

Va modificata anche quest'altra istruzione:
Range(F1St).Range("E" & (I * cItm + 1)).Resize(cItm * (3 - I), 1).ClearContents

Io la modificherei in

Codice: Seleziona tutto

    Range(F1St).Range("E" & (I * cItm + 1)).Resize(cItm * (10 - I), 1).ClearContents


In questo modo la colonna E viene ripulita sempre per circa 10 possibili postazioni (immagino che avrai invece sempre meno di 10 postazioni)

Ciao

[macio66]

Ciao Anthony
Ti ringrazio per il tuo aiuto.
Come sempre, siete un vero aiuto x chi come me è appassionato, ma non sempre in grado, di fare quel qualcosa in più (le idee ci sono, ma metterle in pratica e tutta un'altra cosa).
Grazie ancora e a presto.
Buona serata