Erreur d'exécution 6: dépassement de capacité

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

Merci par avance.