Motes
Messages postés22Date d'inscriptionlundi 20 octobre 2014StatutMembreDernière intervention24 octobre 2014
-
Modifié par pijaku le 20/10/2014 à 11:26
Motes
Messages postés22Date d'inscriptionlundi 20 octobre 2014StatutMembreDernière intervention24 octobre 2014
-
20 oct. 2014 à 14:49
Bonjour,
Je suis nouvelle.
J'ai un souci avec une macro: lorsque je l'a lance elle indique qu'il y a une "erreur d'exécution 6: dépassement de capacité".
J'ai également constaté que la macro fonctionne sur les données de 8000 lignes mais bug sur les données de 700 000 ligne.
Voici le code de la ligne 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
f894009
Messages postés17205Date d'inscriptiondimanche 25 novembre 2007StatutMembreDernière intervention19 octobre 20241 709 Modifié par f894009 le 20/10/2014 à 11:26
Bonjour,
While Not IsEmpty(Cells(Row% + 1, VarStrate.Column))
% apres une variable, Nombre entier de -32768 à 32767. donc pour 700000 pas bon
& apres une variable,Nombre entier de - 2147483648 à 2147483647.
Mais plus simple de declarer par
ex: Dim Point as Long
de plus prendre une variable du meme nom qu'une variable reservee d'excel Row, n'est pas recommende
et enfin, au lieu de faire une boucle infernale, y a surement moyen d'optimiser ce code