Bonjour, je suis nouvelle. j'ai un souci avec une macro: que je l'a lance elle indique qu'il y a une "erreur d'exécution 6: dépassement de capacité". voici le code où il y a l'erreur: While Not IsEmpty(Cells(Row% + 1, VarStrate.Column))
Et Voici la macro en question:
Sub EchantillonStratifié()
'
' Créée par Henry AUBERT le 26/02/1996
' Dernière mise à jour le 09/03/2000
'
' Sélectionner dans une feuille contenant des "données brutes", c'est-à-dire
' un tableau d'observations avec
' les individus en lignes et
' les variables en colonnes, avec leurs libellés en ligne 1
' et le libellé de la variable servant de stratification.
' Lancer la macro.
'
' La macro :
' a) Vérifie la sélection :
' * d'une cellule de la première ligne
' * avec un libellé,
' * et sans données manquantes.
' b) Demande la taille de l'échantillon, avec, par défaut le sondage au 10ème.
' Cette taille est contrôlée, et doit, évidemment, être inférieure à celle de la population
' c) Trie les données selon les valeurs de la variable de stratification,
' d) Place dans une feuille "Stratification" (créée ou remplacée si elle existait déjà)
' les noms, tailles, débuts, fins des strates et les effectifs prélevés
' e) Place dans une feuille "Echantillon" (créée ou remplacée si elle existait déjà)
' un échantillon "représentatif" au hasard sans remise.
' Les effectifs des échantillons des strates sont arrondis :
' Il peut y avoir plus ou moins d'individus dans l'échantillon
' que le nombre demandé.
' f) Note dans la feuille des données brutes
' les "individus" qui ont été sélectionnés dans l'échantillon
'
Application.ScreenUpdating = False
Bandeau = "Tirage au hasard d'un échantillon stratifié représentatif " & Signature
MessageDerreur = "Une erreur indéterminée s'est produite !"
Message = MessageDerreur
On Error GoTo erreur
'
Message = "Sélectionnez (ligne 1) le libellé de la variable de stratification !"
If Selection.Row <> 1 _
Or Selection.Cells.Count > 1 _
Or Selection.Value = Empty Then GoTo erreur
'
' Sauvegarde la stratification demandée :
Set VarStrate = Selection
'
' Compte le nombre de variables, et supprime la colonne dont l'en-tête serait "dans l'éch"
'
NbVar = 0
While NbVar < 255 And Not IsEmpty(Cells(1, NbVar + 1))
If Cells(1, NbVar + 1) = "dans l'éch" Then
Cells(1, NbVar + 1).Select
Message = "Déprotégez la feuille !"
Selection.EntireColumn.Delete
ActiveWorkbook.Save
Message = MessageDerreur
Else
NbVar = NbVar + 1
End If
Wend
'
On Error GoTo 0
Selection.SpecialCells(xlLastCell).Select
'
Message = "Données manquantes pour cette variable !"
If Application.CountBlank(Range(Cells(2, VarStrate.Column), Cells(ActiveCell.Row, VarStrate.Column))) > 0 Then GoTo erreur
Message = MessageDerreur
'
NomVarStrate = VarStrate.Value
NomFeuillePop = ActiveSheet.Name
'
' Trie toutes les données selon la colonne sélectionnée :
'
Range("A1").Select
Selection.Sort Key1:=Range(VarStrate.Address), Order1:=xlAscending, Header:= _
xlGuess, OrderCustom:=1, MatchCase:=False, _
Orientation:=xlTopToBottom
VarStrate.Select
'
Row% = VarStrate.Row ' son numéro de ligne
While Not IsEmpty(Cells(Row% + 1, VarStrate.Column))
Row% = Row% + 1
Wend
Range(Cells(VarStrate.Row + 1, VarStrate.Column).Address(), Cells(Row%, VarStrate.Column).Address()).Select
TaillePop = Selection.Cells.Count
'
Dim NomStrate()
Dim DébutStrate()
Dim TailleStrate()
Dim FinStrate()
Dim EchStrate()
'
NbStrates = 1
ReDim Preserve NomStrate(NbStrates)
ReDim Preserve DébutStrate(NbStrates)
ReDim Preserve TailleStrate(NbStrates)
ReDim Preserve FinStrate(NbStrates)
DébutStrate(NbStrates) = 2
NomStrate(NbStrates) = ActiveCell.Value
TailleStrate(NbStrates) = 0
For Each Individu In Selection
If Individu.Value <> NomStrate(NbStrates) Then
FinStrate(NbStrates) = Individu.Row - 1
NbStrates = NbStrates + 1
ReDim Preserve NomStrate(NbStrates)
ReDim Preserve DébutStrate(NbStrates)
ReDim Preserve TailleStrate(NbStrates)
ReDim Preserve FinStrate(NbStrates)
NomStrate(NbStrates) = Individu.Value
TailleStrate(NbStrates) = 1
DébutStrate(NbStrates) = Individu.Row
Else
TailleStrate(NbStrates) = TailleStrate(NbStrates) + 1
End If
Next
FinStrate(NbStrates) = FinStrate(NbStrates - 1) + TailleStrate(NbStrates)
'
Header = "Entrez la taille de l'échantillon (maxi "
Dim TaillEch As Integer
SaisTaille:
On Error GoTo 0
TailleProposée = TaillePop / 10
TaillEch = Val(InputBox(Header & TaillePop & ")" _
& Chr(10) & Chr(10) & "(0 = Annuler)", _
Bandeau, Str(Int(TailleProposée))))
If TaillEch = 0 Then
VarStrate.Select
End
End If
If TaillEch < 1 Or TaillEch > TaillePop Then
Beep
ErrTaille:
Décision = MsgBox("Valeur erronnée ! Voulez-vous recommencer ?", 4, Bandeau)
If Décision = vbYes Then GoTo SaisTaille
If Décision = vbNo Then
VarStrate.Select
End
End If
End If
' On Error GoTo 0
'
' Calcul et affichage des éléments de stratification
'
ReDim EchStrate(NbStrates)
Total = 0
For i = 1 To NbStrates
EchStrate(i) = Application.Round(TailleStrate(i) * TaillEch / TaillePop, 0)
If EchStrate(i) < 1 Then
Message = "Attention la strate n°" & i _
& " (= " & NomStrate(i) & ")" _
& " de '" & VarStrate & "'" _
& " ne sera pas représentée." _
& Chr(13) _
& "Il faudrait un échantillon de " _
& Application.RoundUp(TaillePop / TailleStrate(i), 0) _
& Chr(13) & "Voulez vous abandonner, réessayer une autre taille, ou continuer ?"
Réponse = MsgBox(Message, vbAbortRetryIgnore, Bandeau)
If Réponse = vbRetry Then GoTo SaisTaille
If Réponse = vbAbort Then
VarStrate.Select
End
End If
End If
Total = Total + EchStrate(i)
Next
For i_feuille = 1 To Sheets.Count
If Sheets(i_feuille).Name = "Stratification" Then
Sheets(i_feuille).Delete
End If
Next
Sheets.Add
ActiveSheet.Name = "Stratification"
'
Cells(1, 1) = "Strate"
Cells(1, 2) = "Taille"
Cells(1, 3) = "Ligne début"
Cells(1, 4) = "Ligne fin"
Cells(1, 5) = "Nb d'éch."
For iLigne = 1 To NbStrates
Cells(iLigne + 1, 1) = NomVarStrate + " = " & NomStrate(iLigne)
Cells(iLigne + 1, 2) = TailleStrate(iLigne)
Cells(iLigne + 1, 3) = DébutStrate(iLigne)
Cells(iLigne + 1, 4) = FinStrate(iLigne)
Cells(iLigne + 1, 5) = EchStrate(iLigne)
Next
Cells(NbStrates + 2, 1) = "Total :"
Cells(NbStrates + 2, 1).HorizontalAlignment = xlRight
Cells(NbStrates + 2, 2) = TaillePop
Cells(NbStrates + 2, 4) = "Total :"
Cells(NbStrates + 2, 4).HorizontalAlignment = xlRight
Cells(NbStrates + 2, 5) = Total
Range(Cells(1, 1), Cells(1, 5)).Select
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlBottom
.WrapText = False
.Orientation = xlHorizontal
.Font.ColorIndex = 45
.Interior.ColorIndex = 35
End With
Range(Cells(1, 1), Cells(NbStrates + 2, 5)).Columns.AutoFit
Cells(1, 1).Select
'
' Prépare feuille Echantillon
'
For i_feuille = 1 To Sheets.Count
If Sheets(i_feuille).Name = "Echantillon" Then
Sheets(i_feuille).Delete
End If
Next
Sheets.Add
ActiveSheet.Name = "Echantillon"
'
' recopier les en-têtes dans la feuille échantillon
'
Sheets(NomFeuillePop).Select
Range(Cells(1, 1), Cells(1, NbVar)).Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Echantillon").Select
Range("A1").Select
ActiveSheet.Paste
'
' Prélèvement et affichage de l'échantillon
'
' prépare colonne marquage individus sélectionnés dans feuille données brutes
Sheets(NomFeuillePop).Select
Cells(1, NbVar + 1).Value = "dans l'éch"
Range(Cells(1, NbVar + 1), Cells(TaillePop + 1, NbVar + 1)).Select
With Selection
.HorizontalAlignment = xlCenter
.Font.ColorIndex = 22
End With
'
NumLigne = 2
For istrate = 1 To NbStrates
iéch = 1
While iéch < EchStrate(istrate) + 1
Randomize ' Initialise le générateur de nombres aléatoires avec l'horloge système
LignAuHasard = Int((FinStrate(istrate) - DébutStrate(istrate) + 2) * Rnd + DébutStrate(istrate))
If Sheets(NomFeuillePop).Cells(LignAuHasard, NbVar + 1).Value = Empty Then
Sheets(NomFeuillePop).Range(Cells(LignAuHasard, 1), Cells(LignAuHasard, NbVar)).Copy
Sheets("Echantillon").Paste Destination:=Sheets("Echantillon").Cells(NumLigne, 1)
NumLigne = NumLigne + 1
Sheets(NomFeuillePop).Cells(LignAuHasard, NbVar + 1).Value = "*"
iéch = iéch + 1
End If
Wend
Next
Sheets(NomFeuillePop).Cells(1, NbVar + 1).Select
Sheets("Echantillon").Select
ActiveSheet.Range("A1").Select
Application.Calculate
GoTo Fin
erreur:
Beep
Réponse = MsgBox(Message, , Bandeau)
Fin:
Application.ScreenUpdating = True
End Sub
Merci.