la fonction ALEA() ne te convient pas.
Bonjour zizoufan, bof,
Eh oui, mais il faut quand même 3 petites formules matricielles, voyez le fichier joint.
A+
Sub Tirage()
Dim nlig&, d As Object, c As Range, i&, c1 As Range
Application.ScreenUpdating = False
With ActiveSheet.UsedRange.EntireRow
nlig = .Rows.Count
.Columns("G").ClearContents 'RAZ
Set d = CreateObject("Scripting.Dictionary")
Randomize
For Each c In .Columns("F").Cells
i = Application.CountIf(.Columns("C"), c)
For i = 1 To IIf(i < 4, i, 4)
Do
Set c1 = .Cells(Int(1 + nlig * Rnd), "D")
Loop While c1(1, 0) <> c Or d.exists(c1.Value)
d(c1.Value) = ""
c(i, 2) = c1
Next
Next
End With
End Sub
Sub Tirage()
Dim deb As Range, P As Range, nlig&, d As Object
Dim c As Range, i&, c1 As Range
Set deb = [F4]
Set P = Range("C4", Range("C" & Rows.Count).End(xlUp)(2))
nlig = P.Rows.Count
Application.ScreenUpdating = False
Randomize
deb.Resize(Rows.Count - deb.Row + 1, 2).ClearContents 'RAZ
Set d = CreateObject("Scripting.Dictionary")
For Each c In P
If c <> "" And Not d.exists(c.Value) Then
d(c.Value) = ""
deb = c
i = Application.CountIf(P, c)
For i = 1 To IIf(i < 4, i, 4)
Do
Set c1 = P(Int(1 + nlig * Rnd), 2)
Loop While c1(1, 0) <> c Or d.exists(c1.Value)
d(c1.Value) = ""
deb(i, 2) = c1
Next
Set deb = deb(5)
End If
Next
End Sub
Sub Tirage()
Dim deb As Range, P As Range, nlig&, d As Object
Dim c As Range, d1 As Object, c1 As Range, i As Byte
Set deb = [F4]
Set P = Range("C4", Range("C" & Rows.Count).End(xlUp)(2))
nlig = P.Rows.Count
Application.ScreenUpdating = False
Randomize
deb.Resize(Rows.Count - deb.Row + 1, 2).ClearContents 'RAZ
Set d = CreateObject("Scripting.Dictionary")
For Each c In P
If c <> "" And Not d.exists(c.Value) Then
d(c.Value) = ""
deb = c
Set d1 = CreateObject("Scripting.Dictionary")
For Each c1 In P.Offset(, 1)
If c1(1, 0) = c Then If Not d1.exists(c1.Value) Then d1(c1.Value) = ""
Next
For i = 1 To IIf(d1.Count < 4, d1.Count, 4)
Do
Set c1 = P(Int(1 + nlig * Rnd), 2)
Loop While c1(1, 0) <> c Or d.exists(c1.Value)
d(c1.Value) = ""
deb(i, 2) = c1
Next
Set deb = deb(5) 'deb(i)
End If
Next
End Sub
Sub Tirage()
Dim deb As Range, P As Range, d As Object, c As Range
Dim d1 As Object, c1 As Range, a, n&, i As Byte, x
Set deb = [F4]
Set P = Range("C4", Range("C" & Rows.Count).End(xlUp)(2))
Application.ScreenUpdating = False
Randomize
deb.Resize(Rows.Count - deb.Row + 1, 2).ClearContents 'RAZ
Set d = CreateObject("Scripting.Dictionary")
For Each c In P
If c <> "" And Not d.exists(c.Value) Then
d(c.Value) = ""
deb = c
Set d1 = CreateObject("Scripting.Dictionary")
For Each c1 In P.Offset(, 1)
If c1(1, 0) = c Then If Not d1.exists(c1.Value) Then d1(c1.Value) = ""
Next
a = d1.keys: n = d1.Count: d1.RemoveAll
For i = 1 To IIf(n < 4, n, 4)
Do
x = a(Int(n * Rnd))
Loop While d1.exists(x)
d1(x) = ""
deb(i, 2) = x
Next
Set deb = deb(5) 'deb(i)
End If
Next
End Sub
Sub Tirage()
Dim ntirage, deb As Range, t, nlig&, d As Object, i&, x, a, h&, rest(), j&, b, n&
ntirage = 4 'paramétrable
Set deb = [F4]
t = Range("C4:D" & Range("C" & Rows.Count).End(xlUp)(2).Row) 'matrice
nlig = UBound(t)
Set d = CreateObject("Scripting.Dictionary")
'---noms sans doublons---
For i = 1 To nlig
x = t(i, 1)
If x <> "" Then d(x) = ""
Next i
If d.Count = 0 Then GoTo 1
'---tirage des ID---
a = d.keys: h = ntirage * d.Count
ReDim rest(1 To h, 1 To 2)
Randomize
For i = 0 To UBound(a)
x = a(i)
rest(ntirage * i + 1, 1) = x
d.RemoveAll
For j = 1 To nlig
If t(j, 1) = x Then d(t(j, 2)) = ""
Next j
b = d.keys: n = d.Count: d.RemoveAll
For j = 1 To IIf(n < ntirage, n, ntirage)
Do
x = b(Int(n * Rnd))
Loop While d.exists(x)
d(x) = ""
rest(ntirage * i + j, 2) = x
Next j
Next i
'---restitution---
deb.Resize(h, 2) = rest
1 deb.Offset(h).Resize(Rows.Count - deb.Row - h + 1, 2).ClearContents
End Sub
Bonjour zizoufan, le forum,
Une solution par tableaux VBA (matrices), bien plus rapide sur de grands tableaux :
Fichier (4).Code:Sub Tirage() Dim ntirage, deb As Range, t, nlig&, d As Object, i&, x, a, h&, rest(), j&, b, n& ntirage = 4 'paramétrable Set deb = [F4] t = Range("C4:D" & Range("C" & Rows.Count).End(xlUp)(2).Row) 'matrice nlig = UBound(t) Set d = CreateObject("Scripting.Dictionary") '---noms sans doublons--- For i = 1 To nlig x = t(i, 1) If x <> "" Then d(x) = "" Next i If d.Count = 0 Then GoTo 1 '---tirage des ID--- a = d.keys: h = ntirage * d.Count ReDim rest(1 To h, 1 To 2) Randomize For i = 0 To UBound(a) x = a(i) rest(ntirage * i + 1, 1) = x d.RemoveAll For j = 1 To nlig If t(j, 1) = x Then d(t(j, 2)) = "" Next j b = d.keys: n = d.Count: d.RemoveAll For j = 1 To IIf(n < ntirage, n, ntirage) Do x = b(Int(n * Rnd)) Loop While d.exists(x) d(x) = "" rest(ntirage * i + j, 2) = x Next j Next i '---restitution--- deb.Resize(h, 2) = rest 1 deb.Offset(h).Resize(Rows.Count - deb.Row - h + 1, 2).ClearContents End Sub
Edit : durées d'exécution des macros :
- fichier (3) => 6,8 millisecondes sur Win XP - Excel 2003 et 3,6 millisecondes sur Win 7 - Excel 2010
- fichier (4) => 1,7 milliseconde sur Win XP - Excel 2003 et 0,9 milliseconde sur Win 7 - Excel 2010
Je pense qu'on a fait le tour du problème.
A+