Extraction aléatoire de lignes avec condition

zizoufan

XLDnaute Occasionnel
Bonjour à tous,

toujours ravi de poster sur ce forum qui me donne satisfaction depuis pas mal de temps.
j'ai une extraction brute qui se présente sous forme de plusieurs colonnes :

N°Dossier // Reponsable du dossier // Objet de la demande // ....

je souhaiterais avoir un script qui me permet de :
1. extraire un nombre de lignes pour chaque responsable de dossier ( qu'il soit paramètrable via un imput box par exemple)
2. que si j'extrait 3 lignes pour le responsable X, l'objet de la demande ne soit pas le même
3. qu'il puisse me dire si j'atteins le quota ( par exemple 10 pour chaque responsable de dossier) que le quota est atteint.

Merci de votre aide précieuse sur le sujet
 

Fichiers joints

mapomme

XLDnaute Barbatruc
Supporter XLD
Bonjour zizoufan,

Bonsoir Qlq'un pourrait il m'aider SVP ? Merci
Minute papillon! Nous ne sommes pas aux pièces. Laissez-nous le temps de comprendre, réfléchir, trouver une méthode, la traduire en code et éventuellement un peu tester... :rolleyes:;)

Un essai dans le fichier joint. Cliquez sur le bouton 'Hop !'

Le code est dans le module de code de la feuille Feuil1 (bdd):
VB:
Sub extraction()
Dim x, NbrDos&, tablo, dico, i&, j&, k&
Dim elem, h&, aux, n&, resp, demande

   'effacement de la précédente extraction
   Range("g1").EntireColumn.Resize(, 5).Clear
   Range("m1").EntireColumn.Resize(, 3).Clear
   Application.ScreenUpdating = False

   'lecture du nombre de dossiers à extraire pour chaque responsable
   x = Application.InputBox("Nbre de dossiers à extraire ?", Default:=3, Type:=2)
   If Not IsNumeric(x) Then
      Exit Sub
   ElseIf Int(x) <= 0 Then
      Exit Sub
   Else
      NbrDos = Int(x)
   End If

   'lecture de la table source
   tablo = Range(Cells(1, "a"), Cells(Rows.Count, "a").End(xlUp)).Resize(, 5).Value

   'on mélange la table des données source
   Randomize
   For i = 2 To UBound(tablo)
      h = 2 + Int(Rnd * (UBound(tablo) - 1))
      For j = 1 To UBound(tablo, 2)
         aux = tablo(i, j): tablo(i, j) = tablo(h, j): tablo(h, j) = aux
      Next j
   Next i

   'dico est un dictionary avec pour clef le responsable et pour item un autre dico (dico1)
   'dico1 est un dictionary avec pour clef l'objet de la demande et pour item un autre dico (dico2)
   'dico2 est dictionary avec pour clef le numéro de ligne de tablo et pour item une chaine vide
   Set dico = CreateObject("scripting.dictionary")
   For i = 2 To UBound(tablo)
      If Not dico.exists(tablo(i, 1)) Then
         'le responsable n'est pas encore répertorié dans dico, on le crée
         Set x = CreateObject("scripting.dictionary")
         dico.Add tablo(i, 1), x
      End If
      If Not dico(tablo(i, 1)).exists(tablo(i, 3)) Then
         'pour le responsable ci-dessus, l'objet de la demande n'est pas encore répertorié, on le crée
         Set x = CreateObject("scripting.dictionary")
         dico(tablo(i, 1)).Add tablo(i, 3), x
      End If
      'pour le responsable ci-dessus, pour l'objet de la demande, on rajoute le numéro de ligne de tablo
      dico(tablo(i, 1))(tablo(i, 3)).Add i, ""
   Next i

   'création de tableau résultat (extraction) puis affichage
   ReDim res(0 To dico.Count * NbrDos, 1 To UBound(tablo, 2))
   'les en-têtes en ligne 0
   For j = 1 To UBound(tablo, 2): res(0, j) = tablo(1, j): Next j
   k = 0
   For Each resp In dico.Keys
      'pour chaque responsable
      n = 0   'nombre de dossiers extraits
      For Each demande In dico(resp)
         'pour chaque 'objet de la demande' (pour le propriétaire resp ci-dessus)
         'on recherche au hasard un numéro parmi le nombre de lignes correspondant
         'au couple (resp, demande)
         h = Int(Rnd * dico(resp)(demande).Count)
         'on lit le numéro de ligne (correspondant dans tablo)
         h = dico(resp)(demande).Keys()(h)
         'on transfère la ligne de tablo dans res
         k = k + 1
         For j = 1 To UBound(tablo, 2): res(k, j) = tablo(h, j): Next j
         'si on a atteint le nombre de dossiers désirés, on sort de la boucle
         n = n + 1: If n = NbrDos Then Exit For
      Next demande
   Next resp
   Range("g1").Resize(1 + UBound(res), UBound(res, 2)) = res

   'création du tableau statistique puis affichage
   ReDim res(0 To dico.Count, 1 To 3): k = 0
   'les en-têtes en ligne 0
   res(0, 1) = "Resp.": res(0, 2) = "Extrait": res(0, 3) = "Manque / " & NbrDos
   'pour chaque responsable de dossier, on recherche le nombre de lignes extraites
   For Each resp In dico.Keys
      k = k + 1: res(k, 1) = resp
      n = dico(resp).Count   'n est le nombre d'objets de la demande (sans doublons)
      'si n est supérieur au nombre de dossier à extraire (nbrdos) alors n est mis à nbrdos
      If n > NbrDos Then n = NbrDos
      res(k, 2) = n
   Next resp
   Range("m1").Resize(1 + UBound(res), UBound(res, 2)) = res
  
   'formatage en dur
   For i = 1 To UBound(res)
      If res(i, 2) < NbrDos Then
         Cells(i + 1, "m").Resize(, 3).Font.Color = RGB(255, 0, 0)
         Cells(i + 1, "m").Offset(, 2) = res(i, 2) - NbrDos
      End If
   Next i
  
  
   'quelques fioritures
   Range("g1").CurrentRegion.Interior.Color = RGB(215, 245, 255)
   Range("g1").CurrentRegion.Borders.LineStyle = xlContinuous
   Range("m1").CurrentRegion.Interior.Color = RGB(255, 250, 155)
   Range("m1").CurrentRegion.Borders.LineStyle = xlContinuous
  
   'tri des résultats
   Range("g1").CurrentRegion.Sort key1:=Range("g1"), order1:=xlAscending, key2:=Range("i1"), order2:=xlAscending, Header:=xlYes
   Range("m1").CurrentRegion.Sort key1:=Range("m1"), order1:=xlAscending, Header:=xlYes
   Application.Goto Range("f1"), True
End Sub
edit: v1a
 

Fichiers joints

Dernière édition:

zizoufan

XLDnaute Occasionnel
Bonjour Mapomme et merci infiniment pour ton prompt retour.
L'appétit vient en mangeant :). En fait, ton script me donne des idées :
1. Imaginons que chaque responsable dépends d'une équipe et qu'il faudrait faire cette extraction par équipe ( distribuée sous les onglets) (Cf. fichier Excel). cette distribution est conditionnée par une feuille COMPO qui est censée évoluer dans le temps
2. Si chaque semaine j'alimente l'onglet BDD par de nouvelles lignes. Est ce qu'il y a possibilité que le script prenne en compte juste les nouvelles lignes quand il fait son "HOP" ( Extraction) et l'ajoute à chaque onglet de l'équipe
3.Finalement, la feuille compo contient aussi leps emails des équipes pourlequels on peut envoyer les extractions faites.

Je pense que ces échanges profiteront à tout le monde.

Cordialement,
 

Fichiers joints

Dernière édition:

zizoufan

XLDnaute Occasionnel
Bonsoir le forum,
j'ai essayé de trouver une solution mais en vain. j'ai trouvé un code intéressant ( cf. fichier ci-joint) mais qui ne réponds pas tout à fait à ma problématique.
@Mapommme si tu peux me débloquer sur ce coup ça sera gentil de ta part.
 

Fichiers joints

zizoufan

XLDnaute Occasionnel
Bsr Mapomme le forum

Je viens aux nouvelles du code.
Pourriez svp me faire un retour ? J en ai vraiment besoin
Vous remerciant d avance pour votre précieuse aide

Cordialement
 

mapomme

XLDnaute Barbatruc
Supporter XLD
Bonsoir zizoufan,

Comme vous semblez pressé;), je livre une version pratiquement pas testée.

Pour une nouvelle intégration :
  • se placer sur la feuille "Nouvelle-Extraction"
  • cliquer sur le bouton "RAZ"
  • coller les nouvelles données à traiter sur cette feuille en veillant à conserver une ligne d'en-têtes pour les colonnes A à F
  • cliquer sur le bouton "Numérotation / Tirage / Ventilation"
La semaine à indiquer est une semaine de votre choix représentative de votre extraction.
Les colonnes K à N indiquent si le traitement est parvenu à son terme ou non.
 

Fichiers joints

Dernière édition:

zizoufan

XLDnaute Occasionnel
Bonjour Mapomme,

C'est juste génial ce que vous pouvez faire avec VBA. un grand bravo !
j'ai testé le fichier ce matin et voilà ce qui marche bien / pas bien :
- La ventilation se fait selon la composition. J'ai même changé de Manager pour certaines personnes et le script l'as pris en compte. Par contre, j'ai un onglet "inconnu" qui se crée je ne sais pourquoi.
Serait-il possible dans ces onglets crées d'ajouter automatiquement 3 colonnes et en fin il faudrait un peu de maquillage ( Coloration de l'entête par exemple...)
- pour un le N° de la semaine je l'ai trouvé un peu compliqué ne faut il pas mettre tout simplement des numéros de semaines ? sans mettre l'année ou bien carrément mettre la date complète de l'extraction ? A voir
- pour le tableau à droite de l'onglet "Nouvelle extraction" cela fonctionne mais cela aurait été mieux d'avoir le nombre total extrait par personne au lieu du nombre extrait par semaine mais je ne sais pas si c'est possible ( une sorte de synthèse)
- L'onglet "juste pour les testes" est à supprimer !? non ?

avec ces échanges et grâce à toi nous sommes entrain de construire un outil sympatoch.

Cordialement,
Zizoufan
 
Dernière édition:

zizoufan

XLDnaute Occasionnel
Bonjour Mapomme Bonjour le forum
j'avance doucement mais surement sur mon petit projet grâce à vous.
je souhaite copier une plage de données d'un fichier fermé "rapport.xls" à mon outil ( fichier élaboré par Mapomme) mais je n'y arrivé pas le code de Jacques BOIGONTIER, pourtant dans son exemple ADOsource cela marche à merveille. pouvez-vous m'aider SVP ?

Erreur SQL INSERT, UPDATE ou DELETE attendu.

Voici le code utilisé :
Sub RecupCopyFrmRecordset()

' Microsoft ActiveX DataObject doit être coché

Set cnn = New ADODB.Connection

répertoire = ThisWorkbook.Path

fichier = "AdoSource.xls"

cnn.Open "Provider=Microsoft.Jet.OLEDB.4.0;" & "Data Source=" & répertoire & "\" & fichier & ";Extended Properties=""Excel 8.0;HDR=No;"";"

Set rs = cnn.Execute("[Feuil1$A1:C100]")

[A1].CopyFromRecordset rs

rs.Close

cnn.Close

Set rs = Nothing

Qu'est ce qui cloche à votre avis ?

Merci

Set cnn = Nothing

End Sub
 

zizoufan

XLDnaute Occasionnel
Bonjour Ma Pomme, Le forum

j'ai une activité où il y a très peu de demandes différentes, ce qui fait que le script n'est pas adapté et comme résultat j'ai 2 ou 3 extractions alors qu'il y a de la matière dans le fichier brut.
comment je peux modifier SVP le script afin de le forcer à prendre des demandes du même type ?
je vous remercie de votre retour

Zizoufan
 

Discussions similaires


Haut Bas