Extraction selon condition 2

[Celine57]

J'ai déjà régler le problème de la création d'onglets automatique selon une liste, maintenant, j'ai souhaite dire à excel selon un modèle type d'extraire les données dans chaque sous tableau et dans chaque onglet.

j'ai par exemple, francis, sandra et jean philippe qui travaillent sur plusieurs dossiers, dossier compta, dossier secretariat et dossier educatif.

Je souhaiterai créer selon un modèle avec 3 sous-tableaux dans chaque onglet (compta - secretariat - educatif) l'extraction de toutes les données qui se trouvent dans une base de données commune.

voilà le code qui permet de créer un onglet selon une liste :

Sub Extrait()

Dim plage As Range

Application.DisplayAlerts = False
Application.ScreenUpdating = False
Set f = Sheets("base")
'--- Liste des travées
f.[J1] = f.[G1]
f.[A1:G10000].AdvancedFilter Action:=xlFilterCopy, CopyToRange:=f.[J1], Unique:=True
For Each c In f.Range("J2:J" & f.[J65000].End(xlUp).Row) ' pour chaque travée
On Error Resume Next
onglet = CStr(c.Value)
Sheets(onglet).Delete
On Error GoTo 0
Sheets("modèle").Copy After:=Sheets(Sheets.Count)
ActiveSheet.Name = onglet
'-- extraction



ligne = 2
For i = 2 To f.[A65000].End(xlUp).Row
If CStr(f.Cells(i, "G")) = onglet Then
Cells(ligne, "A") = f.Cells(i, "G")
Cells(ligne, "J") = f.Cells(i, "D")
Cells(ligne, "I") = f.Cells(i, "C")
ligne = ligne + 1
End If
Next i
Next c
End Sub


En faite c'est la boucle qui permet de dire à excel tant qu'il y a un nom sur la liste (onglet à créer), créer selon modèle avec 3 sous tableaux sur le même onglet en répartissant les données compta, educatif et secrétariat.

Quelqu'un pourrait m'aider svp à concevoir la macro ?

 

[Robert]

Re : Extraction selon condition 2

Bonjour Céline, bonjour le forum,

Comme on a souvent la mauvaise surprise, surtout de la part des nouveaux membres, de n'avoir aucune suite à nos réponses, je voudrais être certain que tu as encore besoin de nous avant de me pencher sur ton problème. En attendant ta réponse...

 

[pierrejean]

Re : Extraction selon condition 2

Bonjour Céline

Salut Robert

Je l'ai fait , je le poste
Comme toi je souhaite ardemment une réponse quelle qu'elle soit

@ Céline :Cliquer sur le bouton ONGLET

 

[titiborregan5]

Re : Extraction selon condition 2

Bonjour à tous,

Effectivement doublon avec ce post https://www.excel-downloads.com/threads/extraction-selon-condition.222970/

où j'avais proposé une réponse par filtre élaboré... je ne sais pas si ça convient...

A+

Tibo

 

[Celine57]

Re : Extraction selon condition 2

Bonjour Robert,

Je suis effectivement nouvelle et je pense rester dans ce forum qui commence à me donner satisfaction, mon objectif est d'avancer dans le monde vba suite à mon nouvel emploi.

Je te dis donc à bientôt Robert

kiss

 

[Celine57]

Re : Extraction selon condition 2

Bonjour Pierrejean,

Je vais tester de suite, en tout les cas je te remercie infiniment pour ton aide précieuse, je démarre un nouvel emploi et j'avais vraiment besoin de me différencier en automatisant certaines tâches répétitives.

A très vite pour la réponse

kiss

 

[Celine57]

Re : Extraction selon condition 2

Pierrejean,

Je viens de tester rapidement la macro et j'ai l'impression que cela fonctionne parfaitement, je vais maintenant l'adapter à mon fichier principal en espérant pouvoir le faire, j'ai visionner ton code vba et je t'avouerai que ce n'est pas évident

je te tiens au courant rapidement, promis

kisssssssss

 

[Celine57]

Re : Extraction selon condition 2

Tibo, j'ai tester ce matin ton code et malheureusement il n'arrive pas à répartir correctement dans les sous tableaux

en tout les cas je te remercie pour l'aide que tu m'a donné

je te dis à bientôt et merci encore mon ami

kissssssssssssss

 

[Robert]

Re : Extraction selon condition 2

Bonjour le fil, bonjour le forum,

Une proposition par Filtre Automatique avec le code ci-dessous :

Sub test()
Dim BD As Object 'déclare la variable BD (onglet BD)
Dim DL As Integer 'déclare la variable DL (Dernièr Ligne)
Dim PL As Range 'déclare la variable PL (PLage)
Dim CEL As Range 'déclare la variable CEL (CELlule)
Dim D As Object 'déclare la variable D (Dictionnaire)
Dim TMP As Variant 'déclare la variable TMP (Tableau TeMPoraire)
Dim I As Byte 'déclare la variable I (Incrément)
Dim O As Object 'déclare la variable O (Onglet)
Dim PLV As Range 'déclare la variable PLV (PLage Visible)

Application.DisplayAlerts = False 'empêche les message Excel
Application.ScreenUpdating = False 'masque les rafraîchissements d'écran
Set BD = Sheets("BD") 'définit'longlet BD
DL = BD.Cells(Application.Rows.Count, 1).End(xlUp).Row 'définit la dernière ligne éditée DL de la colonne 1 (=A) de l'onglet BD
Set PL = BD.Range("A2:A" & DL) 'définit la plage PL
Set D = CreateObject("Scripting.Dictionary") 'définit le dictionnaire D
For Each CEL In PL 'boucle surt toutes les cellules CEL de la plage PL
    D(CEL.Value) = "" 'alimente le dictionnaire D
Next CEL 'prochaine cellule de la boucle
TMP = D.keys 'récupère dans le tableau temporaire TMP la liste des élément du dictionnaire D sans doublon
For I = 0 To UBound(TMP) 'boucle sur tous les éléments uniques du tableau temporaire TMP
    On Error Resume Next 'gestion ds erreurs (en cas d'erreur passe à la ligne suivante)
    Sheets(TMP(I)).Delete 'supprime l'onglet dont le nom est égal à TMP(I) (génère une erreur si cet onglet n'existe pas)
    On Error GoTo 0 'annule la gestion des erreurs
    Sheets("modèle").Copy After:=Sheets(Sheets.Count) 'copie le modèle en dernière position
    ActiveSheet.Name = TMP(I) 'renomme le modèle avec la valeur de TMP(I) comme nom
    Set O = ActiveSheet 'définit l'oneglet O
    BD.Range("A1").AutoFilter Field:=1, Criteria1:=TMP(I) 'filtre la colonne 1 (=A) de l'onglet BD avec TMP(I) comme critère
    BD.Range("A1").AutoFilter Field:=3, Criteria1:="compta" 'filtre la colonne 3 (=C) de l'onglet BD avec "compta" comme critère
    On Error Resume Next 'gestion ds erreurs (en cas d'erreur passe à la ligne suivante)
    Set PLV = PL.Resize(, 4).SpecialCells(xlCellTypeVisible) 'définit la plage PLV (génère une erreur si aucune cellule visible)
    If Err <> 0 Then Err.Clear: GoTo sec 'si une erreur a été générée, efface l'erreur, va à l'étiquette "sec"
    PLV.Copy O.Range("A2") 'copy la plage PLV et la colle dans la cellule A2 de l'onglet O
sec: 'étiquette
    On Error GoTo 0 'annule la gestion des erreurs
    BD.Range("A1").AutoFilter Field:=3, Criteria1:="secretariat" 'filtre la colonne 3 (=C) de l'onglet BD avec "secretariat" comme critère
    On Error Resume Next 'gestion ds erreurs (en cas d'erreur passe à la ligne suivante)
    Set PLV = PL.Resize(, 4).SpecialCells(xlCellTypeVisible) 'définit la plage PLV (génère une erreur si aucune cellule visible)
    If Err <> 0 Then Err.Clear: GoTo edu 'si une erreur a été générée, efface l'erreur, va à l'étiquette "edu"
    PLV.Copy O.Range("A22") 'copy la plage PLV et la colle dans la cellule A22 de l'onglet O
edu: 'étiquette
    On Error GoTo 0 'annule la gestion des erreurs
    BD.Range("A1").AutoFilter Field:=3, Criteria1:="educ" 'filtre la colonne 3 (=C) de l'onglet BD avec "educ" comme critère
    On Error Resume Next 'gestion ds erreurs (en cas d'erreur passe à la ligne suivante)
    Set PLV = PL.Resize(, 4).SpecialCells(xlCellTypeVisible) 'définit la plage PLV (génère une erreur si aucune cellule visible)
    If Err <> 0 Then Err.Clear: GoTo suite 'si une erreur a été générée, efface l'erreur, va à l'étiquette "suite"
    PLV.Copy O.Range("A42") 'copy la plage PLV et la colle dans la cellule A42 de l'onglet O
suite: 'étiquette
    On Error GoTo 0 'annule la gestion des erreurs
    BD.Range("A1").AutoFilter 'supprime le filtre automatique
Next I 'prochaine valeur unique de la boucle
Application.DisplayAlerts = True 'permet les message Excel
Application.ScreenUpdating = True 'affiche les rafraîchissements d'écran
End Sub

Le fichier :

 

[Celine57]

Re : Extraction selon condition 2

Je viens de tester ta proposition Robert et malheureusement lorsque je clique sur le bouton onglets, il créer correctement les onglets mais ne réparti pas les données dans les sous tableaux, en faite, il ne réparti rien du tout, il créer simplement les onglets

je ne sais pas à quoi c'est due

 

[titiborregan5]

Re : Extraction selon condition 2

Qu'est ce qui bloque?
car de mémoire tu souhaitais dans tes sous tableaux des infos qui n'étaient pas présentes dans ta base...
chez moi il y avait la répartition par personne (onglet) et ensuite par type (compta educ ...).

Si la solution pierrejean te convient (ce qui ne m'étonne pas vu la qualité de ses réponses à chaque fois!!!) c'est le principal!
Bonne chance dans ton nouvel emploi!

A+

 

[Celine57]

Re : Extraction selon condition 2

En faite lorsque je modifie la base de donnée, ta macro ne remet pas à jour les tableaux en question.

Effectivement la solution de pierre jean fonctionne et me convient.

En tout les cas je te remercie infiniment Tibo pour ton aide, et on reste en contact bien evidemment.

A bientôt et prend soin de toi

kissss

 

[titiborregan5]

Re : Extraction selon condition 2

En faite lorsque je modifie la base de donnée, ta macro ne remet pas à jour les tableaux en question

Effectivement ça ne se met pas à jour tout seul. Je n'avais pas compris ça dans la consigne!!!

A+

 

[Celine57]

Re : Extraction selon condition 2

ce n'est pas grave, c'est de ma faute, j'aurai du être plus explicite.

A bientôt Tibo

 

[Robert]

Re : Extraction selon condition 2

Bonjour le fil, bonjour le forum,

Je viens de tester ta proposition Robert et malheureusement lorsque je clique sur le bouton onglets, il créer correctement les onglets mais ne réparti pas les données dans les sous tableaux, en faite, il ne réparti rien du tout, il créer simplement les onglets

je ne sais pas à quoi c'est due

Moi non plus, d'autant plus que je télécharge le fichier que je t'ai proposé en pièce jointe, je clique sur le bouton ONGLETS et, chez moi, ça marche impeccable...