Re : Sélection aléatoire et proportionnel (échantillonnage questionnaire de satisfact
Bnjour CBernardT,
Merci pour ta reponse.
Je teste demain avec ma bdd et te tiens au courant!
Encore merci.
Bonsoir CBernardT,
J'ai modifié ma macro car les secteurs sont en colonne L et les organismes en colonne K, et le tirage en O.
Malheureusement, la macro me plante excel à chaque fois.
Voici la macro modifiée. Merci pour ton aide.
Option Explicit
Sub EchantillonsAleatoires()
Dim Derlig As Integer, Tablo, i As Integer, j As Byte, k As Byte
Dim NbPers As Integer, Sect As Object, NbSect As Integer, NombSect, Org As Object, NbOrg As Integer, NombOrg
Dim TabEch, TabTirage, Tirage As Integer, n As Integer
With Sheets("BASE")
Derlig = .Range("B65000").End(xlUp).Row
Tablo = .Range("B2:O" & Derlig)
End With
Set Sect = CreateObject("Scripting.Dictionary")
Set Org = CreateObject("Scripting.Dictionary")
'Recherche du nombre et des noms des secteurs et organismes
For i = 1 To UBound(Tablo, 1)
If Not Sect.exists(Tablo(i, 11)) Then Sect.Add Tablo(i, 11), Tablo(i, 11)
If Not Org.exists(Tablo(i, 10)) Then Org.Add Tablo(i, 10), Tablo(i, 10)
Next i
NbPers = UBound(Tablo, 1) ' Nombre de personnes
NbSect = Sect.Count ' Nombre de secteurs
NbOrg = Org.Count ' Nombre d'organismes
' Définition des dimensions du tableau de l'échantillon
ReDim TabEch(1 To NbOrg * 2 + 3, 1 To NbSect + 1)
' Mise en place des noms des secteurs dans le tableau
NombSect = Sect.keys
For i = 0 To Sect.Count - 1
TabEch(1, i + 2) = NombSect(i)
Next
' Mise en place des noms des organismes dans le tableau
NombOrg = Org.keys
For i = 0 To Org.Count - 1
TabEch(i + 2, 1) = NombOrg(i)
TabEch(i + NbOrg + 4, 1) = NombOrg(i)
Next
' Recherche et mise en tableau du nombre de personnes d'un organisme par secteur
For i = 1 To UBound(Tablo, 1)
For j = 2 To NbOrg + 2 ' Boucle sur les organismes existants
For k = 2 To NbSect + 1 ' Boucle sur les secteurs existants
If Tablo(i, 10) = TabEch(j, 1) And Tablo(i, 11) = TabEch(1, k) Then
TabEch(j, k) = TabEch(j, k) + 1
TabEch(NbOrg + 2, k) = TabEch(NbOrg + 2, k) + 1
End If
Next k
Next j
Next i
' Calcul de l'échantillon de personnes à 20% par secteur avec minimum 20
For j = 2 To NbSect + 1
If TabEch(NbOrg + 2, j) / 5 < 20 Then
TabEch(NbOrg + 3, j) = TabEch(NbOrg + 2, j)
Else
TabEch(NbOrg + 3, j) = Application.Round(TabEch(NbOrg + 2, j) / 5, 0)
End If
' Calcul du nombre de personnes par organisme et par secteur
For k = NbOrg + 4 To NbOrg * 2 + 3
If TabEch(k - (NbOrg + 2), j) = "" Then
TabEch(k, j) = ""
Else
TabEch(k, j) = Application.Round(TabEch(NbOrg + 3, j) / TabEch(NbOrg + 2, j) * TabEch(k - (NbOrg + 2), j), 0)
End If
Next k
Next j
' Tirage au sort des personnes selon le nombre calculé de personnes par organisme et par secteur
ReDim TabTirage(1 To NbPers, 1 To 1)
For j = 2 To NbSect + 1
For k = NbOrg + 4 To NbOrg * 2 + 3
If TabEch(k, j) <> "" Then
n = 0
Do
Do
Tirage = Int((NbPers * Rnd) + 1) ' Tirage aléatoire d'une ligne
Loop Until Tablo(Tirage, 10) = TabEch(k, 1) And Tablo(Tirage, 11) = TabEch(1, j) And TabTirage(Tirage, 1) = ""
TabTirage(Tirage, 1) = "X" ' Marquage du tirage
n = n + 1
Loop Until n = TabEch(k, j)
End If
Next k
Next j
' Report des résultats du tirage aléatoire dans la base
Sheets("BASE").Range("O2:O" & Derlig) = TabTirage
End Sub