aide vba
Hors ligneMotes Le 17/10/2014 à 15:50 Profil de Motes Configuration de Motes

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.

Hors ligneKoytlo2 Le 17/10/2014 à 16:48 Profil de Koytlo2 Configuration de Koytlo2

salut je sais plus mais je crois que c'est une erreur de macro. Tu as du vouloir faire une manoeuvre qui n'est pas accépté par les macros. Mais c'est du non pas à toi mais à une limitation de la macro. macro windows ou log ? change de log salut
Hors ligneAnthony Le 17/10/2014 à 17:19 Profil de Anthony Configuration de Anthony

Fou du volant

Hello,

Dépassement de capacité, cela veut dire qu'un moment tu cherches à faire appel à une case qui n'existe pas dans un tableau.

Si on regarde ta ligne Cells(Row% + 1, VarStrate.Column) il y a soit un pb au niveau du Row%+1 qui un moment devient trop grand (ou qu'il est trop petit inférieur à 0 probablement), ou alors le varstrate.column qui est trop grand (ou trop petit)

Il faudrait regarder les valeurs de tes variables pour voir ce qui cloche.

--

Hors ligneMotes Le 20/10/2014 à 09:54 Profil de Motes Configuration de Motes

Merci Anthony,

La macro marche sur une base de données de 8000 lignes mais ne fonctionne pas sur les données de 702 000 lignes.

Pour ce qui est des valeurs des variables, c'est du qualitatif.

Que faire?


Merci par avance.

Hors ligneAnthony Le 20/10/2014 à 22:35 Profil de Anthony Configuration de Anthony

Fou du volant

Dans tes 702 000 lignes, as-tu essayé de voir progressivement à partir de quelle ligne cela ne fonctionne plus ? Cette ligne est-elle particulière ?

--

Hors ligneMotes Le 23/10/2014 à 09:19 Profil de Motes Configuration de Motes

Bonjour Anthony,

J'ai remplacé row% par row et ça marche sur toutes les tailles de données.

Merci.

Hors ligneAnthony Le 23/10/2014 à 13:26 Profil de Anthony Configuration de Anthony

Fou du volant

Heureux Super ;) Merci d'avoir apporté la réponse à ton souci Sourire

--

Vous avez résolu votre problème avec VIC ? Faites-le savoir sur les réseaux sociaux !
Vulgarisation-informatique.com
Cours en informatique & tutoriels