VBA - Supprimer aléatoirement un nombre défini de ligne

Le 02/03/2022 à 18:29

Bonjour,

Je dois créer un échantillon aléatoire dans un fichier qui contient x ligne.

Je souhaiterais garder uniquement 20 lignes de ce fichier et cela de façon aléatoire.

J'ai cru comprendre que je pouvais utiliser la fonction While de VBA mais je ne vois pas comment...

Connaitriez vous un code qui puisse me permettre de faire cela ?

Merci d'avance pour votre aide.

Le 02/03/2022 à 19:04

Bonjour Pauline

Tes données en Feuil1 ton choix de lignes en feuil2, essaie cela:

Sub LignesAuHasard()
    DLig = Worksheets("Feuil1").Range("A65536").End(xlUp).Row
    For i = 1 To 20
        Randomize
        x = Int(Rnd * DLig + 1)
        Worksheets("Feuil1").Rows(x).Copy Destination:=Worksheets("Feuil2").Rows(i)
    Next
End Sub

Dis moi

Le 02/03/2022 à 19:14

Bonsoir Patty5046

Ca fonctionne merci beaucoup.

Cependant je ne peux pas avoir de doublon dans mon échantillon et là c'est le cas. Pourrais tu me dire comment je peux faire pour intégrer dans le code d'avoir un choix aléatoire sans doublon ?

(C'était pour cela que je pensais supprimer et pas copier dans une autre feuille, parce que normalement la fonction ne peux pas supprimer quelque chose 2 fois ?)

Le 02/03/2022 à 19:29

bonsoir,

une autre proposition (sans doublons)

Sub aargh()
    Set ws = Sheets.Add
    With Sheets("sheet1")
        dl = .Cells(Rows.Count, 1).End(xlUp).Row
        .Columns(1).Insert shift:=xlToRight
        For i = 1 To 20
            Do
                q = aleatoire(1, dl)
            Loop Until .Cells(q, 1) = ""
            .Cells(q, 1) = 1
        Next i
        .Rows("1:" & dl).Sort key1:=.Cells(1, 1), Order1:=xlDescending, Header:=xlNo
        .Columns(1).Delete shift:=xlLeft
        .Rows("1:20").Copy ws.Cells(1, 1)
    End With
End Sub

Function aleatoire(borne_inférieure, borne_supérieure)
    aleatoire = Int(Rnd() * (borne_supérieure - borne_inférieure + 1)) + borne_inférieure
End Function
Le 02/03/2022 à 19:50

Bonjour h2so4,

J'ai lancé le code. J'ai laissé en running pendant 15 min mais mon fichier est passé en "Not responding".

J'ai l'impression qu'une boucle était a l'infini. J'ai donc fermé le fichier et réouvert et ca m'a créer une nouvelle feuille nommé "Sheet1" et il y a un 1 dans la cellule A1

Le 02/03/2022 à 20:29

Bonsoir,

un test inspiré de la solution de Patty5046:

Sub LignesAuHasard()
Dim Dlig As Long, lig As Long
Dim tailleEchantillon As Integer, nbValeurs As Integer, ligDep As Integer
Dim tabLignes As Variant

'initialisations
nbValeurs = 0
ligDep = 2 'ligne 1 = en-têtes
Dlig = Worksheets("Feuil1").Range("A" & Rows.Count).End(xlUp).Row
tailleEchantillon = 20
ReDim tabLignes(1 To tailleEchantillon)

If Dlig - ligDep + 1 < tailleEchantillon Then
    MsgBox "Il n'y a pas assez de valeurs pour créer un échantillon de cette taille", vbInformation, "Information"
Else
    While nbValeurs < tailleEchantillon
        Randomize
        lig = Int(Rnd * (Dlig - (ligDep - 1)) + 1 + ligDep - 1)

        If Not estDoublon(lig, tabLignes) Then
            nbValeurs = nbValeurs + 1
            Worksheets("Feuil1").Rows(lig).Copy Worksheets("Feuil2").Rows(ligDep + nbValeurs - 1)
            tabLignes(nbValeurs) = lig
        End If
    Wend
End If
End Sub

Function estDoublon(ByVal valeur, ByVal tableau) As Boolean 'false par défaut
If IsArray(tableau) Then
    For i = LBound(tableau, 1) To UBound(tableau, 1)
        If valeur = tableau(i) Then
            estDoublon = True
            Exit For
        End If
    Next i
End If
End Function

Bon c'est pas la solution la plus optimale car il faudrait sûrement plutôt avoir une collection qu'on vide au fur et à mesure mais bon...

Le 02/03/2022 à 20:50

RE

Bonjour à tous...j'avais zappé que tu voulais supprimer des lignes:

Sub SupprimerLignesAuHasard()
    DLIg = Worksheets("Feuil1").Range("A65536").End(xlUp).Row
    For i = 1 To 20
        Randomize
        x = Int(Rnd * DLIg + 1)
        Worksheets("Feuil1").Rows(x).EntireRow.Delete
        DLIg = DLIg - 1
    Next
End Sub

Bonne soirée à tous

Le 02/03/2022 à 21:33

Du coup j'ai modifié un autre code que j'ai trouvé sur un autre site et ca fonctionne :

Sub Sampling()
Dim Plage As Range, I As Integer, DerLigne As Integer
DerLigne = Range("A" & Rows.Count).End(xlUp).Row
I = Rnd() * DerLigne + 1
Set Plage = Range("A" & I)
While Plage.Count < DerLigne - 20
I = Rnd() * DerLigne
Set Plage = Union(Plage, Range("A" & I))
Wend
Plage.EntireRow.Delete
End Sub

N'hésitez pas à me dire s'il y a une erreur ou si on peut l'améliorer.

@Ausecour ton code fonctionne super merci beaucoup !

@Patty5046 ton code ne me supprime que 20 lignes au lieu de m'en conserver que 20.

Merci encore pour votre aide.

Je vous souhaite une excellent soirée.

Le 02/03/2022 à 21:49
pauuliine21 a écrit :

Du coup j'ai modifié un autre code que j'ai trouvé sur un autre site et ca fonctionne :

Sub Sampling()
Dim Plage As Range, I As Integer, DerLigne As Integer
DerLigne = Range("A" & Rows.Count).End(xlUp).Row
I = Rnd() * DerLigne + 1
Set Plage = Range("A" & I)
While Plage.Count < DerLigne - 20
I = Rnd() * DerLigne
Set Plage = Union(Plage, Range("A" & I))
Wend
Plage.EntireRow.Delete
End Sub

N'hésitez pas à me dire s'il y a une erreur ou si on peut l'améliorer.

@Ausecour ton code fonctionne super merci beaucoup !

@Patty5046 ton code ne me supprime que 20 lignes au lieu de m'en conserver que 20.

Merci encore pour votre aide.

Je vous souhaite une excellent soirée.

Techniquement je dirais qu'il est améliorable oui, pour déjà une raison, plutôt que de chercher à supprimer plein de lignes aléatoirement jusqu'à ce qu'il ne reste que le nombre désiré, il peut-être plus rapide de sélectionner un certains nombre de lignes, en plus j'ai l'impression que ton code gère aussi mal les doublons que celui que j'ai fait, il va simplement reboucler encore et encore si les lignes sur lesquelles tu tombes sont déjà présentes, donc j'aurais tendance à dire que c'est du temps perdu niveau calcul.

J'ai une préférence pour une autre méthode mais je ne suis pas réellement sûr qu'elle soit plus rapide, je n'ai étrangement jamais fait de tests pour comparer les vitesses d'exécution avec une autre méthode.

Après si pour ton besoin ça fonctionne suffisamment vite et bien, pas trop besoin de l'améliorer.

Ah et je viens de trouver une petite erreur:

tu mets à la ligne 4:

I = Rnd() * DerLigne + 1

puis ça à la ligne 7:

I = Rnd() * DerLigne

Après ce n'est pas quelque chose qui ne va pas faire fonctionner ton code, mais je ne déclare jamais sur la même ligne des variables de type différent, et j'utilise une méthode de nommage légèrement différente de la tienne, le Camel Case, et je ne mets une première lettre majuscule que quand il s'agit d'objet (Range par exemple), pas de simples variables comme un Integer.

Le 02/03/2022 à 23:09

Bonsoir à tous

Sub SupprimerLignesAuHasard()
    DLig = Worksheets("Feuil1").Range("A65536").End(xlUp).Row
    Application.ScreenUpdating = False
    For i = 1 To DLig - 20
        Randomize
        x = Int(Rnd * DLig + 1)
        Worksheets("Feuil1").Rows(x).EntireRow.Delete
        DLig = DLig - 1
    Next
    Application.ScreenUpdating = True

End Sub

Voilà enfin ... environ 30 secondes

Le 03/03/2022 à 00:14

bonsoir,

heureux pour toi que tu aies trouvé une solution.

J'ai lancé le code. J'ai laissé en running pendant 15 min mais mon fichier est passé en "Not responding".

En fait il faut remplacer "sheet1" par le nom de ta feuille qui contient tes données à sélectionner. la macro créera une nouvelle feuille avec les 20 lignes sélectionnées.

la macro se base sur la première colonne pour déterminer le nombre de lignes de ton fichier. s'il y en a moins de 20, cas que je n'avais pas prévu, tu as en effet un boucle sans fin.

Rechercher des sujets similaires à "vba supprimer aleatoirement nombre defini ligne"