extraire liste suivant critères sur autre page

[thespeedy20]

Bonjour à tous.....

J'ai une base de données et j'aimerais extraire sous format de liste et suivant des critères bien précis....

Je fais appel aux membres de ce forum pour essayer de solutionner mon problèmes....

Une petite solution en vba ?

D'avance merci à tous pour votre aide

 

[job75]

Bonsoir thespeedy20,

La seule astuce est cette fonction VBA, dans Module1 :

Function Initiales(t$)
Dim i%
t = " " & t
For i = 2 To Len(t)
  If Mid(t, i - 1, 1) = " " Then Initiales = Initiales & Mid(t, i, 1)
Next
Initiales = UCase(Initiales) 'majuscules
End Function

Le reste, dans le code de la feuille "Résultat", est classique avec le filtre avancé :

Private Sub Worksheet_Activate()
Application.ScreenUpdating = False
Range("A2:B" & Rows.Count).Delete xlUp 'RAZ
With Feuil1 'CodeName de la feuille "Base"
.[C2] = "=(A2=G$3)*(Initiales(B2)=H$3)+(A2=G$4)*(Initiales(B2)=H$4)+(Initiales(B2)=H$6)+(Initiales(B2)=H$7)" 'critère
.[A1].CurrentRegion.AdvancedFilter xlFilterCopy, .[C1:C2], [A2]
.[C2] = ""
End With
[A1].CurrentRegion.Offset(1).Sort [A1], xlAscending, Header:=xlYes 'tri
Columns.AutoFit 'ajustement largeur
With Me.UsedRange: End With 'actualise la barre de défilement verticale
End Sub

Fichier joint.

A+

 

[job75]

Bonjour thespeedy20, le forum,

Si l'on veut insérer des lignes pour séparer les cours :

Private Sub Worksheet_Activate()
Dim t, resu$(), i&, n&
Application.ScreenUpdating = False
Range("A2:B" & Rows.Count).Delete xlUp 'RAZ
With Feuil1 'CodeName de la feuille "Base"
.[C2] = "=(A2=G$3)*(Initiales(B2)=H$3)+(A2=G$4)*(Initiales(B2)=H$4)+(Initiales(B2)=H$6)+(Initiales(B2)=H$7)" 'critère
.[A1].CurrentRegion.Resize(, 2).AdvancedFilter xlFilterCopy, .[C1:C2], [A3]
.[C2] = ""
End With
[A3].CurrentRegion.Sort [A3], xlAscending, Header:=xlYes 'tri
Columns.AutoFit 'ajustement largeur
'---insertion de lignes---
t = [A3].CurrentRegion.Resize(, 2) 'matrice, plus rapide
ReDim resu(1 To 2 * UBound(t), 1 To 2)
resu(1, 1) = t(1, 1): resu(1, 2) = t(1, 2): n = 1
For i = 2 To UBound(t)
  n = n + 1 - (t(i - 1, 1) <> t(i, 1))
  resu(n, 1) = t(i, 1): resu(n, 2) = t(i, 2)
Next
[A3].Resize(n, 2) = resu
With Me.UsedRange: End With 'actualise la barre de défilement verticale
End Sub

L'exécution est très rapide car on utilise des tableaux VBA.

Fichier (2).

Bonne journée.

 

[job75]

Re,

Dans ce fichier (3) on peut utiliser les caractères génériques * et ? dans les critères.

Avec cette fonction VBA supplémentaire dans Module1 :

Option Compare Text 'la casse est ignorée (pour Like)
'---
Function Rech(t$, critere$) As Boolean
Rech = t Like critere
End Function

et le critère du filtre avancé :

 .[C2] = "=Rech(A2,G$3)*Rech(Initiales(B2),H$3)+Rech(A2,G$4)*Rech(Initiales(B2),H$4)+Rech(Initiales(B2),H$6)+Rech(Initiales(B2),H$7)" 'critère

A+

 

[thespeedy20]

Bonjour Job75,
Bonjour le Forum,

un tout grand merci pour ces propositions qui fonctionnent à merveille.

J'ai une petite requête.... est il possible d'exclure un cours de la recherche ? ici je désirerais exclure le cours de pluridisciplinaire sans l'exclure de la base. es-ce possible ?

et encore merci pour le temps consacré....

 

[job75]

ici je désirerais exclure le cours de pluridisciplinaire sans l'exclure de la base. es-ce possible ?

Le critère d'exclusion étant en G9 :

 .[C2] = "=(ISERROR(SEARCH(G$9,A2))+ISBLANK(G$9))*(Rech(A2,G$3)*Rech(Initiales(B2),H$3)+Rech(A2,G$4)*Rech(Initiales(B2),H$4)+Rech(Initiales(B2),H$6)+Rech(Initiales(B2),H$7))" 'critère

Edit : ceci est un tout petit peu plus léger (gain de 1 octet en mémoire sur la formule) :

 .[C2] = "=ISERROR(SEARCH(G$9,A2)/LEN(G$9))*(Rech(A2,G$3)*Rech(Initiales(B2),H$3)+Rech(A2,G$4)*Rech(Initiales(B2),H$4)+Rech(Initiales(B2),H$6)+Rech(Initiales(B2),H$7))" 'critère

Fichier (4).

A+

 

[thespeedy20]

Bonjour job75,
Bonjour le forum

merci... je viens d'ajouter deux colonnes supplémentaires, j'ai adapter avec des boucles... peux tu vérifier si c'est correct... merci d'avance

Bonne journée

 

[job75]

Bonjour thespeedy20,

Fichier (5) avec le code corrigé (entre autre un Next était mal placé).

PS : en l'état l'UserForm ne sert vraiment à rien !!!

A+

 

[thespeedy20]

Bonjour Job75,
Bonjour le Forum,

un tout grand merci pour les corrections apportées....
c'est vrai que l'userform se sert à rien, je l'ai supprimé.....

Je tiens encore à te remercier vivement pour le temps consacré....

je clôture ici ce poste....

 

[thespeedy20]

Bonjour le forum,
Bonjour à tous,

Meilleurs vœux pour cette nouvelle année.....

Bonjour Job75,

Je reviens vers toi après avoir utilisé un petit moment le fichier....j'aimerais aussi ajouter une ligne à chaque changement de degré dans le même cours ( voir ex dans le fichier ci-joint)... merci

Olivier

 

[job75]

Bonjour thespeedy20,

Merci pour vos vœux, je vous souhaite aussi une excellente année.

Le problème est facile à régler : tri sur 2 colonnes et modification du test de décalage de lignes.

Le fichier en retour.

A+

 

[thespeedy20]

Bonsoir Job75,
Bonsoir le forum

Je te remercie encore pour ta rapidité, et je m'excuse de ma réponse tardive suite à des événements imprévus ou je n'ai pas pu me connecter....

Voilà ton fichier fonctionne à merveille comme d'habitude...
je te remercie pour le temps et la patience....

Olivier

 

[thespeedy20]

Bonjour job75,
Bonjour Le forum....

Job75 , au poste 6, je t 'avais demandé pour une exclusion... ici j'aimerais avoir une exclusion avec un degré....

Ex: Danse Q5 , je ne vois pas comment ajouter le degré... et peut-être un autre cours avec son degré...

Je te remercie pour ton aide....

Olivier

 

[job75]

Bonjour thespeedy20, le forum,

Le plus simple est d'introduire cette nouvelle fonction :

Function Exclu(t1$, t2$, critere1$, critere2$) As Boolean
If critere1 = "" Then Exclu = True: Exit Function
If critere2 = "" Then critere2 = "*"
Exclu = Not t1 & Initiales(t2) Like critere1 & critere2
End Function

Très simplement le critère de filtrage commence ainsi :

.[Z2] = "=Exclu(A2,B2,G$9,H$9)*Exclu(A2,B2,G$10,H$10)*(...)

Fichier (2) avec l'exclusion de Guitare/FA1 et Guitare/FA2.

Bonne journée.

 

[thespeedy20]

Bonjour Job75,

Merci pour ta rapidité, cela fonctionne impeccablement bien...

Si j'ai besoin de mettre à jour la base de donnée, est il possible de créer un bouton qui me permettrait d'aller chercher un fichier excel et installer la nouvelle base... (effacement de l'ancienne et installation de la nouvelle)...

Merci et un très bon dimanche à tous....

Oli