[Excel] macro che suddivide item in gruppi

[tombu]

Buongiorno a tutti!

Sto cercando di impostare una macro ma non so bene da dove cominciare, ho provato ad applicare la soluzione in http://www.pc-facile.com/forum/viewtopic.php?t=95591 ma senza successo..


Ho una lista di persone in colonna A, e una loro scelta (tra "a" e "b") in colonna B.
Una volta indicato in una cella il numero di gruppi che ho necessità di creare (in E3 nell'esempio qui sotto), ho bisogno che la macro assegni ogni persona ad un gruppo (idealmente nella colonna C) tenendo bilanciate le proporzioni tra "scelta a" e "scelta b", a parte l'ultimo gruppo naturalmente nel caso in cui il numero delle persone da smistare non sia perfettamente divisibile.

per spiegarmi meglio, un esempio:


Vi ringrazio fin d'ora per il tempo dedicatomi! Non riesco proprio a capire da che parte cominciare.. Se non volete scrivere l'intera macro mi potrebbe essere utilissimo anche solo un accenno sul metodo che potrebbe risolvere il problema. Grazie davvero!

[Anthony47]

Intanto Benvenuto nel forum

Partendo dal layout dei dati che hai allegato ho impostato questo codice:

Codice: Seleziona tutto

Sub Gruppa()
Dim RArr(), Lastr As Long, GrArr(), GRP As Long
Dim gNum As Long, cMax As Single, myMatch
Dim tbStart As String, Grps As String
'
tbStart = "A1"      '<<< L'origine della Tabella dati
Grps = "E3"         '<<< La cella col N° gruppi
'
Lastr = Range(tbStart).Cells(1, 1).Offset(1000, 0).End(xlUp).Row
ReDim RArr(1 To Lastr - 1)
gNum = Range(Grps).Value
If gNum < 1 Then Exit Sub
mytim = Timer
reTry:
    Range(tbStart).Offset(1, 2).Resize(Lastr, 1).ClearContents
    Randomize
    Erase GrArr
    ReDim GrArr(1 To gNum)
    DoEvents
For I = 1 To Lastr - 1
    RArr(I) = Rnd()
Next I
For I = 2 To Cells(Rows.Count, 1).End(xlUp).Row
    cMax = Application.WorksheetFunction.Max(RArr)
    myMatch = Application.Match(cMax, RArr, False)
    GRP = ABLow(gNum, Range(tbStart).Cells(1, 1), Range(tbStart).Offset(myMatch, 1).Value)
    Range(tbStart).Offset(myMatch, 2).Value = GRP
    GrArr(GRP) = GrArr(GRP) + 1
    RArr(myMatch) = 0
    DoEvents
Next I
If (Application.WorksheetFunction.Max(GrArr) - _
      Application.WorksheetFunction.Min(GrArr)) > 1 Then
    If Timer > (mytim + 10) Or Timer < mytim Then Exit Sub
    Debug.Print "Ripeti " & cippo
    cippo = cippo & "."
    DoEvents
    GoTo reTry
End If
MsgBox ("Completato...")
End Sub



Function ABLow(ByVal grNum As Long, ByRef BaseTab As Range, ByVal cPref As String) As Long
Dim ABArr() As Single, GrArr() As Long, cGr As Long, I As Long, cLow As Single, iLow As Long
'
ReDim ABArr(1 To grNum)
ReDim GrArr(1 To grNum)
'
For I = 1 To BaseTab.End(xlDown).Row
    cGr = BaseTab.Offset(I, 2).Value
    If cGr <> 0 Then
        GrArr(cGr) = GrArr(cGr) + 1
        If UCase(BaseTab.Offset(I, 1)) = UCase(cPref) Then
            ABArr(cGr) = ABArr(cGr) + 1
        End If
    End If
Next I
cLow = 1000
reLook:
    lcnt = lcnt + 1
    If lcnt > 100 Then Stop
    xlow = Application.WorksheetFunction.Small(ABArr, 1)
    ylow = Application.WorksheetFunction.Small(GrArr, 1)
    iLow = Application.Match(xlow, ABArr, False)
    If GrArr(iLow) > ylow Then ABArr(iLow) = ABArr(iLow) + 0.001: GoTo reLook
ABLow = iLow
End Function


Va messo in un "Modulo Standard del vba", vedi viewtopic.php?f=26&t=103893&p=647675#p647675

Le righe marcate <<< vanno personalizzate come da commenti
Poi all'occorrenza devi eseguire la Sub Gruppa dopo aver attivato il foglio con i dati; per le varie opzioni, vedi viewtopic.php?f=26&t=103893&p=647678#p647678

Fai sapere...

[tombu]

Fai sapere...

G R A Z I E !!!!! Funziona benissimo, è strepitoso!!!!!

Unica domanda (posso arrangiarmi anche così ma vorrei capire bene il codice): se nella mia base dati ho qualche colonna in più tra la colonna "Nome" e la colonna "Scelta", facendo sì che la colonna "Scelta" si trovi dunque ad esempio alla colonna E al posto che alla B, quali modifiche devo apportare? In questo caso i numeri dei gruppi generati dovrebbero andare nella colonna F.

Ho capito che vanno modificati degli "Offset" ma non sono sicuro che basti..

Grazie ancora e auguri di uno splendido 2020

[Anthony47]

Vanno controllate le istruzioni all'interno della Sub Gruppa che fanno riferimento al Range(tbStart) con un Offset di colonna diverso da 0; e all'interno della Function ABLow le istruzioni che fanno riferimento a BaseTab sempre con offset diverso da 0.
Ora offset "1" fa riferimento alla colonna contenente la "Scelta", e offset "2" fa riferimento alla colonna "Gruppo"; dovrai quindi adeguare "1" e "2" al tuo nuovo layout.

Ciao