Sub extraction()
Dim x, NbrDos&, tablo, dico, i&, j&, k&
Dim elem, h&, aux, n&, resp, demande
'effacement de la précédente extraction
Range("g1").EntireColumn.Resize(, 5).Clear
Range("m1").EntireColumn.Resize(, 3).Clear
Application.ScreenUpdating = False
'lecture du nombre de dossiers à extraire pour chaque responsable
x = Application.InputBox("Nbre de dossiers à extraire ?", Default:=3, Type:=2)
If Not IsNumeric(x) Then
Exit Sub
ElseIf Int(x) <= 0 Then
Exit Sub
Else
NbrDos = Int(x)
End If
'lecture de la table source
tablo = Range(Cells(1, "a"), Cells(Rows.Count, "a").End(xlUp)).Resize(, 5).Value
'on mélange la table des données source
Randomize
For i = 2 To UBound(tablo)
h = 2 + Int(Rnd * (UBound(tablo) - 1))
For j = 1 To UBound(tablo, 2)
aux = tablo(i, j): tablo(i, j) = tablo(h, j): tablo(h, j) = aux
Next j
Next i
'dico est un dictionary avec pour clef le responsable et pour item un autre dico (dico1)
'dico1 est un dictionary avec pour clef l'objet de la demande et pour item un autre dico (dico2)
'dico2 est dictionary avec pour clef le numéro de ligne de tablo et pour item une chaine vide
Set dico = CreateObject("scripting.dictionary")
For i = 2 To UBound(tablo)
If Not dico.exists(tablo(i, 1)) Then
'le responsable n'est pas encore répertorié dans dico, on le crée
Set x = CreateObject("scripting.dictionary")
dico.Add tablo(i, 1), x
End If
If Not dico(tablo(i, 1)).exists(tablo(i, 3)) Then
'pour le responsable ci-dessus, l'objet de la demande n'est pas encore répertorié, on le crée
Set x = CreateObject("scripting.dictionary")
dico(tablo(i, 1)).Add tablo(i, 3), x
End If
'pour le responsable ci-dessus, pour l'objet de la demande, on rajoute le numéro de ligne de tablo
dico(tablo(i, 1))(tablo(i, 3)).Add i, ""
Next i
'création de tableau résultat (extraction) puis affichage
ReDim res(0 To dico.Count * NbrDos, 1 To UBound(tablo, 2))
'les en-têtes en ligne 0
For j = 1 To UBound(tablo, 2): res(0, j) = tablo(1, j): Next j
k = 0
For Each resp In dico.Keys
'pour chaque responsable
n = 0 'nombre de dossiers extraits
For Each demande In dico(resp)
'pour chaque 'objet de la demande' (pour le propriétaire resp ci-dessus)
'on recherche au hasard un numéro parmi le nombre de lignes correspondant
'au couple (resp, demande)
h = Int(Rnd * dico(resp)(demande).Count)
'on lit le numéro de ligne (correspondant dans tablo)
h = dico(resp)(demande).Keys()(h)
'on transfère la ligne de tablo dans res
k = k + 1
For j = 1 To UBound(tablo, 2): res(k, j) = tablo(h, j): Next j
'si on a atteint le nombre de dossiers désirés, on sort de la boucle
n = n + 1: If n = NbrDos Then Exit For
Next demande
Next resp
Range("g1").Resize(1 + UBound(res), UBound(res, 2)) = res
'création du tableau statistique puis affichage
ReDim res(0 To dico.Count, 1 To 3): k = 0
'les en-têtes en ligne 0
res(0, 1) = "Resp.": res(0, 2) = "Extrait": res(0, 3) = "Manque / " & NbrDos
'pour chaque responsable de dossier, on recherche le nombre de lignes extraites
For Each resp In dico.Keys
k = k + 1: res(k, 1) = resp
n = dico(resp).Count 'n est le nombre d'objets de la demande (sans doublons)
'si n est supérieur au nombre de dossier à extraire (nbrdos) alors n est mis à nbrdos
If n > NbrDos Then n = NbrDos
res(k, 2) = n
Next resp
Range("m1").Resize(1 + UBound(res), UBound(res, 2)) = res
'formatage en dur
For i = 1 To UBound(res)
If res(i, 2) < NbrDos Then
Cells(i + 1, "m").Resize(, 3).Font.Color = RGB(255, 0, 0)
Cells(i + 1, "m").Offset(, 2) = res(i, 2) - NbrDos
End If
Next i
'quelques fioritures
Range("g1").CurrentRegion.Interior.Color = RGB(215, 245, 255)
Range("g1").CurrentRegion.Borders.LineStyle = xlContinuous
Range("m1").CurrentRegion.Interior.Color = RGB(255, 250, 155)
Range("m1").CurrentRegion.Borders.LineStyle = xlContinuous
'tri des résultats
Range("g1").CurrentRegion.Sort key1:=Range("g1"), order1:=xlAscending, key2:=Range("i1"), order2:=xlAscending, Header:=xlYes
Range("m1").CurrentRegion.Sort key1:=Range("m1"), order1:=xlAscending, Header:=xlYes
Application.Goto Range("f1"), True
End Sub