Tirage sur un colonne sans doublons (grd base données )

julie211 · 30 Octobre 2014

Bonjour à tous,

Je suis novice en vba et je n'ai pas été capable de trouver une solution à mon problème malgré de nombreuses discussions sur le sujet.

J'ai une grande base données (plus de 100000 lignes) et je voudrais trouver un moyen de tirer aléatoirement et sans doublon un nombre variable sur une colonne (1000 par exemple) pour les travailler indépendamment dans un autre onglet en copiant les colonnes correspondants.

Je vous joint un exemple du format de ma fiche de travail: je voudrais tirer 300 dossiers sur la colonne C ( référence) aléatoire sans doublons parmi plus de 700 dossiers au total, et après copier coller dans un autre onglet ''feuil2" qui est en même format que "feuil1".

comme j'ai une grande base de donnée, il faudrait peut-être optimiser le temps de tourne le macro.

Merci d'avance pour votre aide.

Cordialement,

Julie

Bebere · 30 Octobre 2014

Re : Tirage sur un colonne sans doublons (grd base données )

bonjour Julie
bienvenue
voilà un début
code dans module1
en commentaire(texte en vert) dans le code adapter 300

julie211 · 31 Octobre 2014

Re : Tirage sur un colonne sans doublons (grd base données )

Bonjour,

Merci pour votre aide, le fichier de test marche tres bien, j'ai adapté à mon fichier de travail, comme c grde base donnees, le macro est en cours de tourner.

Cordialement,
Julie

julie211 · 31 Octobre 2014

Re : Tirage sur un colonne sans doublons (grd base données )

Y a-t-il une methode à optimiser le tps ou pas? ca prend presque 1h30, mais le macro est tjs en cours tourner.... (ma base est 180000 lignes, et pour tirer 1000)

Merci d avance pour l aide.

Julie

julie211 · 31 Octobre 2014

Re : Tirage sur un colonne sans doublons (grd base données )

le macro ne fonctionne pas vraiment aleatoire, il a tiré les 1000 données seulement sur 1 guichet, en plus, un peu en ordre, qqn peut m'aider sur ce fichier ci-joint? (feuil3 et feuil4 ac module 2 adapté)

Bebere · 31 Octobre 2014

Re : Tirage sur un colonne sans doublons (grd base données )

bonjour Julie
normalement c'est un code très rapide
il faut un début à tout
aléatoire, tu veux vraiment un tirage sans doublon

le macro ne fonctionne pas vraiment aleatoire, il a tiré les 1000 données seulement sur 1 guichet, en plus, un peu en ordre, qqn peut m'aider sur ce fichier ci-joint? (feuil3 et feuil4 ac module 2 adapté)

si bien compris le dernier post,pas de fichier
edit tu parles de celui que tu as mis en 1er

julie211 · 31 Octobre 2014

Re : Tirage sur un colonne sans doublons (grd base données )

Bonjour, Bebere

En faite, tout à l'heure, j'ai essayé de mettre mon fichier, ms comme ca depasse la limit de taille, ps reussi.
enfaite, parmi mes 180000 lignes ( 106 guichet), je veux tirer 1000 aleatoirement, j'ai fini le macro ds 2h, ms qui m'a donnée un nombre seulement pour 1 seul guichet, surtout tous les 10 premiers en ordre, il me semble un peu bizarre, car si c'est vraiment aleatoire, generalement ca va donner le meme proportion selon la categorie ou bien le nombre de guichet.

En plus, quand ca copy coller à feuil4, il y a des fautes de date pour les colonnes E F M.

Voici un fichier de meme format du travail, je peux pas mettre tous les données à cause de taille de fichier.

julie211 · 31 Octobre 2014

Re : Tirage sur un colonne sans doublons (grd base données )

voici le macro j'ai adapté:
Sub test()

Dim a(), tbl, item
Dim dico As New Dictionary, mondico As New Dictionary 'si problème tu commentes mettre ' en début de ligne
Dim i As Long, j As Long, indice As Long, clé As String, clébase As String

Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Set dico = CreateObject("scripting.dictionary") 'si problème tu décommentes
Feuil4.Range("A5😛1000").ClearContents
tbl = Feuil3.UsedRange
j = 1

For i = 5 To UBound(tbl, 1)
dico(tbl(i, 11)) = tbl(i, 11)
Next

For Each item In dico.Items
Set mondico = CreateObject("scripting.dictionary") 'si problème tu décommentes

For i = 5 To UBound(tbl, 1)
If tbl(i, 11) = item Then
clébase = item
clé = clébase
indice = 1
Do While mondico.Exists(clé)
clé = clébase & indice
indice = indice + 1
Loop
mondico(clé) = i
End If

Next i

clébase = item
clé = clébase
indice = 1

Do While mondico.Exists(clé)
ligne = mondico(clé)

ReDim Preserve a(1 To 16, 1 To j)

a(1, j) = tbl(ligne, 1)
a(2, j) = tbl(ligne, 2)
a(3, j) = tbl(ligne, 3)
a(4, j) = tbl(ligne, 4)
a(5, j) = tbl(ligne, 5)
a(6, j) = tbl(ligne, 6)
a(7, j) = tbl(ligne, 7)
a(8, j) = tbl(ligne, 8)
a(9, j) = tbl(ligne, 9)
a(10, j) = tbl(ligne, 10)
a(11, j) = tbl(ligne, 11)
a(12, j) = tbl(ligne, 12)
a(13, j) = tbl(ligne, 13)
a(14, j) = tbl(ligne, 14)
a(15, j) = tbl(ligne, 15)
a(16, j) = tbl(ligne, 16)

clé = clébase & indice
indice = indice + 1

If j < 20 Then j = j + 1 ' adapter 20
Loop
Next item
a = Application.Transpose(a)
Feuil4.Range("A5").Resize(UBound(a, 1), UBound(a, 2)) = a 'c'est pr copy coller?
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic

Bebere · 31 Octobre 2014

Re : Tirage sur un colonne sans doublons (grd base données )

Julie
le code n'est pas aléatoire,il prend 1000 lignes
je posais la question si tu voulais un tirage aléatoire sans doublon
quel est le but
si tu recommences une 2ème fois tu risques de tirer les mêmes en partie

job75 · 31 Octobre 2014

Re : Tirage sur un colonne sans doublons (grd base données )

Bonjour julie211, salut Bebere,

Un code très différent, sans aucune boucle :

Code:

Sub TiragesAléatoires()
Dim n&, P As Range
n = 300 '1000 'nombre de lignes à retenir, à adapter
Application.ScreenUpdating = False
ActiveSheet.Copy 'document auxiliaire
ActiveSheet.Rows("1:3").Delete
Set P = ActiveSheet.UsedRange
With P.Columns(P.Columns.Count + 1) 'colonne auxiliaire à droite
  .Formula = "=RAND()"
  .Value = .Value 'supprime les formules
  .Cells(1) = 0
  Union(P, .Cells).Sort .Cells, xlAscending 'tri
  .EntireColumn.Delete 'suppression de la colonne auxiliaire
End With
P.Columns(11).AdvancedFilter xlFilterInPlace, Unique:=True 'filtre les doublons
With Feuil2 'CodeName de la feuille de restitution
  .Rows("4:" & .Rows.Count).Delete 'RAZ
  P.SpecialCells(xlCellTypeVisible).EntireRow.Copy .[A4]
  .Rows(n + 5 & ":" & .Rows.Count).Delete
  n = .UsedRange.Rows.Count 'ajuste la barre de défilement verticale
  .Columns.AutoFit 'ajustement de la largeur des colonnes
  .Activate
End With
P.Parent.Parent.Close False 'fermeture du document auxiliaire
End Sub

Ci-joint votre dernier fichier adapté.

Nota 1 : pour repérer les lignes il serait plus logique de mettre des numéros qui se suivent en colonne A...

Nota 2 : sur 180000 lignes l'exécution devrait prendre quelques dizaines de secondes.

Edit : attention, je viens de me rendre compte que le fichier est en mode de calcul manuel 😡

A+

job75 · 31 Octobre 2014

Re : Tirage sur un colonne sans doublons (grd base données )

Re,

J'avais oublié ces 2 lignes, j'ai corrigé le post précédent :

Code:

'----
  .Rows(n + 5 & ":" & .Rows.Count).Delete
  n = .UsedRange.Rows.Count 'ajuste la barre de défilement verticale

En fait on pourrait s'en passer...

A+

job75 · 31 Octobre 2014

Re : Tirage sur un colonne sans doublons (grd base données )

Re,

Je n'avais pas fait attention, mais il y avait des lignes vides dans le .UsedRange à la fin du tableau.

Ce qui entrainait l'inclusion d'une ligne vide dans le résultat.

Je l'évite donc en recherchant la dernière ligne par la méthode Find :

Code:

Sub TiragesAléatoires()
Dim n&, derlig&, P As Range
n = 300 '1000 'nombre de lignes à retenir, à adapter
Application.ScreenUpdating = False
ActiveSheet.Copy 'document auxiliaire
With ActiveSheet
  derlig = .Cells.Find("*", , xlValues, , xlByRows, xlPrevious).Row
  Set P = Intersect(.UsedRange, .Rows("4:" & IIf(derlig < 5, 5, derlig)))
End With
With P.Columns(P.Columns.Count + 1) 'colonne auxiliaire à droite
  .Formula = "=RAND()"
  .Value = .Value 'supprime les formules
  .Cells(1) = 0
  Union(P, .Cells).Sort .Cells, xlAscending 'tri
  .EntireColumn.Delete 'suppression de la colonne auxiliaire
End With
P.Columns(11).AdvancedFilter xlFilterInPlace, Unique:=True 'filtre les doublons
With Feuil2 'CodeName de la feuille de restitution
  .Rows("4:" & .Rows.Count).Delete 'RAZ
  P.SpecialCells(xlCellTypeVisible).EntireRow.Copy .[A4]
  .Rows(n + 5 & ":" & .Rows.Count).Delete
  n = .UsedRange.Rows.Count 'ajuste la barre de défilement verticale
  .Columns.AutoFit 'ajustement de la largeur des colonnes
  .Activate
End With
P.Parent.Parent.Close False 'fermeture du document auxiliaire
End Sub

Fichier (2).

Nota : dans ce fichier il n'y a pas de doublon en colonne K...

Edit : attention, je viens de me rendre compte que le fichier est en mode de calcul manuel 😡

Bonne nuit et A+

KenDev · 1 Novembre 2014

Re : Tirage sur un colonne sans doublons (grd base données )

Bonjoir Julie, Bebere, Job,

Une autre proposition avec le code ci-après adapté au fichier fourni au post 1. La sub est à lancer depuis la feuille contenant les données (associer à un bouton par exemple).

Seule la ligne avec un commentaire devrait être modifiée selon le cas réel.
_ b=4 car le premier dossier apparait ligne 4,
_ d=3 car les numéros de dossiers sont en colonne 3, mais n'importe quel numéro de colonnes ne pouvant contenir de cellules vides conviendra,
_ n=300, le nombre échantillon désiré.

La Sub a été testée pour un échantillon de 1.000 sur 209.356 lignes et 4 colonnes, durée environ 3 secondes.
Echantillon 10.000 sur 209.356 lignes et 4 colonnes, durée environ 4 secondes.

Cordialement

KD

VB:

Sub Echantillon()
    Dim n&, r&, a&(), p#, i&, c&, b&, d%, w As Worksheet, e%, j%
    Application.ScreenUpdating = False: Application.Calculation = xlCalculationManual
    b = 4: d = 3: n = 300                               '1ère ligne contenant un dossier/colonne des dossiers/nb de dossiers demandés
    r = Cells(Rows.Count, d).End(xlUp).Row - b + 1
    If n > r Then Exit Sub
    ReDim a(1 To n): p = n / r: Randomize
    For i = 1 To r - 1
        If Not Rnd > p Then c = c + 1: a(c) = i: n = n - 1
        p = n / (r - i)
    Next i
    If n = 1 Then a(UBound(a)) = r
    e = Cells(1, Columns.Count).End(xlToLeft).Column        'la 1ère ligne doit contenir des intitulés de colonnes
    Set w = ActiveSheet: Sheets.Add: w.Cells.Copy Destination:=[A1]
    Range(Cells(b, 1), Cells(Rows.Count, Columns.Count)).ClearContents
    For i = 1 To UBound(a): For j = 1 To e: Cells(i + b - 1, j) = w.Cells(a(i) + b - 1, j): Next j, i
    Application.ScreenUpdating = True: Application.Calculation = xlCalculationAutomatic
End Sub

Edit:

Au vu du fichier fourni au post 7, on aurait (b devient le n° de la ligne de titre et simplifie très légèrement le code):

VB:

Sub Echantillon7()
    Dim n&, r&, a&(), p#, i&, c&, b&, d%, w As Worksheet, e%, j%
    Application.ScreenUpdating = False: Application.Calculation = xlCalculationManual
    b = 4: d = 11: n = 300                               'ligne de titres/colonne dossier/nb de dossiers demandés
    r = Cells(Rows.Count, d).End(xlUp).Row - b
    If n > r Then Exit Sub
    ReDim a(1 To n): p = n / r: Randomize
    For i = 1 To r - 1
        If Not Rnd > p Then c = c + 1: a(c) = i: n = n - 1
        p = n / (r - i)
    Next i
    If n = 1 Then a(UBound(a)) = r
    e = Cells(b, Columns.Count).End(xlToLeft).Column
    Set w = ActiveSheet: Sheets.Add: w.Cells.Copy Destination:=[A1]
    Range(Cells(b + 1, 1), Cells(Rows.Count, Columns.Count)).ClearContents
    For i = 1 To UBound(a): For j = 1 To e: Cells(i + b, j) = w.Cells(a(i) + b, j): Next j, i
    Application.ScreenUpdating = True: Application.Calculation = xlCalculationAutomatic
End Sub

job75 · 1 Novembre 2014

Re : Tirage sur un colonne sans doublons (grd base données )

Bonjour le fil, le forum, salut KenDev,

J'ai testé ma macro du post #12 sur 200000 lignes (797 valeurs uniques en colonne K).

Elle s'exécute en 29 secondes dont 24 secondes pour l'élimination des doublons par cette ligne :

Code:

P.Columns(11).AdvancedFilter xlFilterInPlace, Unique:=True 'filtre les doublons

En utilisant un tableau VBA pour cette élimination, la durée passe à 6,8 secondes (avec n = 1000) :

Code:

Sub TiragesAléatoires()
Dim n&, derlig&, P As Range, t, ncol%, d As Object, i&, ni&, j%
n = 300 '1000 'nombre de lignes à retenir, à adapter
n = n + 1 'en ajoutant la ligne de titres
Application.ScreenUpdating = False
ActiveSheet.Copy 'document auxiliaire
With ActiveSheet
  derlig = .Cells.Find("*", , xlValues, , xlByRows, xlPrevious).Row
  Set P = Intersect(.UsedRange, .Rows("4:" & derlig))
End With
With P.Columns(P.Columns.Count + 1) 'colonne auxiliaire à droite
  .Formula = "=RAND()"
  .Value = .Value 'supprime les formules
  .Cells(1) = 0
  Union(P, .Cells).Sort .Cells, xlAscending 'tri
  .EntireColumn.Delete 'suppression de la colonne auxiliaire
End With
'---élimination des doublons---
t = P 'tableau VBA (matrice)
ncol = UBound(t, 2)
Set d = CreateObject("Scripting.Dictionary")
For i = 1 To UBound(t)
  If Not d.exists(t(i, 11)) Then
    d(t(i, 11)) = ""
    ni = ni + 1
    For j = 1 To ncol
      t(ni, j) = t(i, j)
    Next
    If ni = n Then Exit For
  End If
Next
'---restitution---
With Feuil2 'CodeName de la feuille de restitution
  .Rows("4:" & .Rows.Count).Delete 'RAZ
  P.Rows("1:2").EntireRow.Copy .[A4]  'pour les formats
  If ni > 1 Then .Rows(5).AutoFill .Rows(5).Resize(ni - 1), xlFillFormats
  .[A4].Resize(ni, ncol) = t
  .Columns.AutoFit 'ajustement de la largeur des colonnes
  .Activate
End With
P.Parent.Parent.Close False 'fermeture du document auxiliaire
End Sub

Fichier joint (4 + 796 lignes).

Bonne journée et A+

Edit : attention, je viens de me rendre compte que le fichier est en mode de calcul manuel 😡

Staple1600 · 1 Novembre 2014

Re : Tirage sur un colonne sans doublons (grd base données )

Bonjour à tous

Job75
Par curiosité (et si j'ai bien compris ton code), avec les versions supérieures à 2003
Est-ce que la nouvelle fonctionnalité Supprimer les doublons est plus ou moins rapide que le filtre élaboré?

VB:

Sub TiragesAléatoiresII()
Dim n&, P As Range
n = 300 '1000 'nombre de lignes à retenir, à adapter
Application.ScreenUpdating = False
ActiveSheet.Copy 'document auxiliaire
ActiveSheet.Rows("1:3").Delete
Set P = ActiveSheet.UsedRange
With P.Columns(P.Columns.Count + 1) 'colonne auxiliaire à droite
  .Formula = "=RAND()"
  .Value = .Value 'supprime les formules
  .Cells(1) = 0
  Union(P, .Cells).Sort .Cells, xlAscending 'tri
  .EntireColumn.Delete 'suppression de la colonne auxiliaire
End With
'P.Columns(11).AdvancedFilter xlFilterInPlace, Unique:=True 'filtre les doublons
P.Columns(11).RemoveDuplicates Columns:=1, Header:=xlYes
With Feuil2 'CodeName de la feuille de restitution
  .Rows("4:" & .Rows.Count).Delete 'RAZ
  P.SpecialCells(xlCellTypeVisible).EntireRow.Copy .[A4]
  .Rows(n + 5 & ":" & .Rows.Count).Delete
  n = .UsedRange.Rows.Count 'ajuste la barre de défilement verticale
  .Columns.AutoFit 'ajustement de la largeur des colonnes
  .Activate
End With
P.Parent.Parent.Close False 'fermeture du document auxiliaire
End Sub

PS: Si quand on teste ta version initiale et qu'on arrête le code sur:
P.Columns(11).AdvancedFilter xlFilterInPlace, Unique:=True 'filtre les doublons
et qu'on regarde le filtre, il s'affiche

Pourquoi le critère affiche G1 et pourquoi Extraction sans doublon est décochée alors que dans le VBA True est indiqué ?

Tirage sur un colonne sans doublons (grd base données )

julie211

XLDnaute Nouveau

Pièces jointes

Bebere

XLDnaute Barbatruc

Pièces jointes

julie211

XLDnaute Nouveau

julie211

XLDnaute Nouveau

julie211

XLDnaute Nouveau

Bebere

XLDnaute Barbatruc

julie211

XLDnaute Nouveau

Pièces jointes

julie211

XLDnaute Nouveau

Bebere

XLDnaute Barbatruc

job75

XLDnaute Barbatruc

Pièces jointes

job75

XLDnaute Barbatruc

job75

XLDnaute Barbatruc

Pièces jointes

KenDev

XLDnaute Impliqué

job75

XLDnaute Barbatruc

Pièces jointes

Staple1600

XLDnaute Barbatruc

Discussions similaires

Tirage sur un colonne sans doublons (grd base données )

XLDnaute Nouveau

Pièces jointes

XLDnaute Barbatruc

Pièces jointes

XLDnaute Nouveau

XLDnaute Nouveau

XLDnaute Nouveau

XLDnaute Barbatruc

XLDnaute Nouveau

Pièces jointes

XLDnaute Nouveau

XLDnaute Barbatruc

XLDnaute Barbatruc

Pièces jointes

XLDnaute Barbatruc

XLDnaute Barbatruc

Pièces jointes

XLDnaute Impliqué

XLDnaute Barbatruc

Pièces jointes

XLDnaute Barbatruc

Discussions similaires

Privacy & Transparency

Privacy & Transparency