Formulaire de recherche

[Tahititin]

Bonjour le Forum,
J'ai trouvé sur le forum un code trés pratique et qui m'aiderais dans mon travail (en PJ : RECHERCHE) mais comme je ne suis pas une lumière en VBA, j'ai tenté de l'adapter à mon fichier (également en JJ : PROGRAMME OPERATOIRE GENERAL) mais en vain.
Ce programme opératoire général dispose déjà d'une macro qui va "scanner" les programmes opératoires de chaque spécialité (il y en a 8 en tout) pour en faire une synthèse hebdomadaire toutes spécialités confondus.
Le problème étant que beaucoup de chirurgiens aimeraient pouvoir faire des recherches sur ce programmes opératoire.
Ce que je souhaiterais c'est pouvoir disposer d'un formulaire de recherche (un peu comme l'exemple joint) ou les chirurgiens pourraient effectuer une recherche par nom de patient (colonne B) et/ou Par opérateur (colonne I) et/ou par spécialités (colonne X). Le résultat de la recherche doit aller scanner les 4 ( voire 5) semaines que constitue le mois. Pour plus de lisibilité, les résultats de la recherche ne doivent pas contenir l'ensemble des information d'une ligne mais seulement la date, les nom/prénom du patient, l'age, le sexe, l'opérateur et l'intervention.

J'ai essayé de modifier le code pour l'adapter à ma problématique, mais c'est la première fois que j'utilise un userform... et je vous avoue que je suis un peu perdu. D'ailleurs, si le formulaire de recherche pouvait être fixe sur un onglet "recherche", je pense qu'on y gagnerait en simplicité et donc en compréhension pour mes chères collègues chirurgiens.

D'avance merci de votre précieuse aide

 

[job75]

Re : Formulaire de recherche

Re,

Là j'avoue mon incompétence, mais si les références sont là avec mon fichier cela prouve qu'elles sont bien trouvées...

Tripotez un peu

A+

 

[Tahititin]

Re : Formulaire de recherche

Job75,
Sur tes consilles, j'ai tripotais un peu... J'ai trouvé les références, elles n'apparaissaient pas sur un fichier vierge, mais quand j'ai "copier-coller" l'onglet "recherche" sur sur mon fichier d'origine, je les ai retrouvé et ça fonctionne parfaitement !!! Par contre lorsque je lance ma macro de synthèse, j'ai toujours le débogage Erreur d'exécution 1004 à la ligne suivante :
x.Range("A3").CurrentRegion.Offset(2, 0).Sort Key1:=x.Range("A3"), Order1:=xlAscending, Key2:=x.Range(ColServ), Order2:=xlAscending, Header:=xlYes

Je pense avoir trouvé le problème mais malheureusement pas la solution : mon fichier "PROGRAMME OPERATOIRE GENERALE" ici celui de Aout10, est composé de 5 onglet, 1 par mois (Semaine 31 à Semaine 35) la macro viens "scanner" les fichiers excel des programmes opératoires par spécialités, qui contiennent également 5 onglet, 1 par mois (Semaine 31 à Semaine 35). Je pense que le problème vient du fait que j'ai rajouter un onglet recherche dans mon programme opératoire général (6 au lieu de 5). Pour preuve, orque que lance ma macro de synthèse, j'ai le débogage, et mon onglet synthèse est modifié : Je n'ai plus que 2 mois qui apparaissent dans ta liste de nome "Mois" (A3) et idem pour les spécialités il ne m'enreste que 2. Le blocage du code (cf. ci-dessus) interviens pour une mise en forme en A3 !!!!

J'ai compressé mon fichier finalisé (avec l'onglet "recherche" et ma macro) mais malheureusement il est trop lourd pour que je puisse l'envoyer via le forum. Je te joint donc ma macro, si tu as une idée pour me sortir de ce pétrin ! Désolé de m'accorcher autant mais je ne suis pas de nature à baisser les bras si facilement... je sens que je suis proche du but !

Sub Test()
NbCol = 24 'Nombre de Colonnes de la base
ColServ = "I3" 'Cellule pour la 2eme clé de tri. Service ou Opérateur
'----------------------
Application.ScreenUpdating = False
For Each x In ThisWorkbook.Sheets 'Boucle sur les feuille du planning général
x.Range("A4:T65536").Clear 'Efface les feuilles
Next
Chemin = ThisWorkbook.Path 'Définit le chemin des fichiers. Peut etre modifié ou rendu fixe => Chemin = C:\TOTO
Set Dossier = CreateObject("Scripting.FileSystemObject").GetFolder(Chemin) 'Définit le dossier d'ouverture des plannings
For Each Fichier In Dossier.Files 'Boucle sur les fichiers contenus dans le dossier
If Right(Fichier.Name, 3) = "xls" And Fichier.Name <> ThisWorkbook.Name Then 'Si ce sont des ".xls" et qu'ils sont differents de ce classeur alors ...
Set MonClass = Workbooks.Open(Chemin & "\" & Fichier.Name) 'On ouvre le classeur qu'on asscie à "MonClass"
For Each Feuille In MonClass.Sheets 'Boucle sur les feuilles de MonClass
If Left(Feuille.Name, 7) = "Semaine" Then 'si le nom commence par "Semaine" ...
'---------------- Modifié ici --------------------
For Each Cel In Feuille.Range("A4:A" & Feuille.Range("A65536").End(xlUp).Row + Feuille.Range("A65536").End(xlUp).MergeArea.Rows.Count - 1) 'Boucle sur les cellules de la colonne A
'-------------------------------------------------
If Cel.Offset(0, 1) <> "" Then 'Si la cellule NOM/Prénom est non vide ...
Set CelDest = ThisWorkbook.Sheets(Feuille.Name).Range("A65536").End(xlUp).Offset(1, 0) 'Définition de la cellule de destination. Derniere cellule vide
With CelDest
.Value = Cel.MergeArea.Resize(1, 1).Value 'récupération de la date
.Font.Bold = True 'formatage en Gras
.Font.Size = 14 'taille 14
End With
Cel.Offset(0, 1).Resize(, NbCol).Copy 'Copie de la ligne
CelDest.Offset(0, 1).PasteSpecial Paste:=xlPasteValues 'Collage valeurs
CelDest.Offset(0, 1).PasteSpecial Paste:=xlPasteFormats 'Collage formats
End If
Next Cel
End If
Next Feuille
MonClass.Close False 'Fermeture du classeur
End If
Next Fichier
'--------------- Mise en forme -------------------------------------
For Each x In ThisWorkbook.Sheets 'Boucle sur les feuilles du classeur
x.Range("A3").CurrentRegion.Offset(2, 0).Sort Key1:=x.Range("A3"), Order1:=xlAscending, Key2:=x.Range(ColServ), Order2:=xlAscending, Header:=xlYes 'tri par date et par Service (ou autre à défnir au début de la macro)
If x.Range("A65536").End(xlUp).Row < 4 Then Exit For 'Si pas de données dans la colonne A on sort de la boucle
For Each Y In x.Range("A4:" & x.Range("A65536").End(xlUp).Address) 'Boucle que la colonne A
If Y.Offset(1, 0) = Y Then 'Tant que la valeur du dessous est egale à celle-ci ..
i = i + 1 'on incremente i
Else
If i > 0 Then Application.DisplayAlerts = False: Y.Offset(-i, 0).Resize(i + 1).Merge: Application.DisplayAlerts = True 'si la valeur est differente => changement de date => fusion des cellules en fontion de i
Y.HorizontalAlignment = xlCenter 'Alignement
Y.VerticalAlignment = xlCenter 'Alignement
With Y.Offset(-i, 0).Resize(i + 1, NbCol) 'Encadrements
.Borders.Weight = xlMedium
.Borders(xlInsideVertical).Weight = xlThin
If i <> 0 Then .Borders(xlInsideHorizontal).Weight = xlThin
End With
i = 0
End If
Next Y
x.Range("A1").Resize(1, NbCol).EntireColumn.AutoFit
Next x
Application.ScreenUpdating = True
End Sub

PS : je vis, travaille et écrit depuis Papeete (Tahiti), il y a 12h de décallage Horaire. Ici tout le monde se tutoie. J'espère que je ne (vous) t'ai pas offencé en utilisant le tutoiement dans mes post.

Encore un grand merci de ton aide

 

[job75]

Re : Formulaire de recherche

Bonjour Tahititin,

Puisqu'on a ajouté la feuille "Recherche", bien sûr, il ne faut pas la traiter dans votre macro (code en rouge) :

Sub Test()
NbCol = 24 'Nombre de Colonnes de la base
ColServ = "I3" 'Cellule pour la 2eme clé de tri. Service ou Opérateur
'----------------------
Application.ScreenUpdating = False
For Each x In ThisWorkbook.Sheets 'Boucle sur les feuille du planning général
[COLOR="Red"]If x.Name <> "Recherche" Then[/COLOR] x.Range("A4:T65536").Clear 'Efface les feuilles
Next
Chemin = ThisWorkbook.Path 'Définit le chemin des fichiers. Peut etre modifié ou rendu fixe => Chemin = C:\TOTO
Set Dossier = CreateObject("Scripting.FileSystemObject").GetFold er(Chemin) 'Définit le dossier d'ouverture des plannings
For Each Fichier In Dossier.Files 'Boucle sur les fichiers contenus dans le dossier
If Right(Fichier.Name, 3) = "xls" And Fichier.Name <> ThisWorkbook.Name Then 'Si ce sont des ".xls" et qu'ils sont differents de ce classeur alors ...
Set MonClass = Workbooks.Open(Chemin & "\" & Fichier.Name) 'On ouvre le classeur qu'on asscie à "MonClass"
For Each Feuille In MonClass.Sheets 'Boucle sur les feuilles de MonClass
If Left(Feuille.Name, 7) = "Semaine" Then 'si le nom commence par "Semaine" ...
'---------------- Modifié ici --------------------
For Each Cel In Feuille.Range("A4:A" & Feuille.Range("A65536").End(xlUp).Row + Feuille.Range("A65536").End(xlUp).MergeArea.Rows.C ount - 1) 'Boucle sur les cellules de la colonne A
'-------------------------------------------------
If Cel.Offset(0, 1) <> "" Then 'Si la cellule NOM/Prénom est non vide ...
Set CelDest = ThisWorkbook.Sheets(Feuille.Name).Range("A65536"). End(xlUp).Offset(1, 0) 'Définition de la cellule de destination. Derniere cellule vide
With CelDest
.Value = Cel.MergeArea.Resize(1, 1).Value 'récupération de la date
.Font.Bold = True 'formatage en Gras
.Font.Size = 14 'taille 14
End With
Cel.Offset(0, 1).Resize(, NbCol).Copy 'Copie de la ligne
CelDest.Offset(0, 1).PasteSpecial Paste:=xlPasteValues 'Collage valeurs
CelDest.Offset(0, 1).PasteSpecial Paste:=xlPasteFormats 'Collage formats
End If
Next Cel
End If
Next Feuille
MonClass.Close False 'Fermeture du classeur
End If
Next Fichier
'--------------- Mise en forme -------------------------------------
For Each x In ThisWorkbook.Sheets 'Boucle sur les feuilles du classeur
[COLOR="Red"]If x.Name <> "Recherche" Then[/COLOR]
x.Range("A3").CurrentRegion.Offset(2, 0).Sort Key1:=x.Range("A3"), Order1:=xlAscending, Key2:=x.Range(ColServ), Order2:=xlAscending, Header:=xlYes 'tri par date et par Service (ou autre à défnir au début de la macro)
If x.Range("A65536").End(xlUp).Row < 4 Then Exit For 'Si pas de données dans la colonne A on sort de la boucle
For Each Y In x.Range("A4:" & x.Range("A65536").End(xlUp).Address) 'Boucle que la colonne A
If Y.Offset(1, 0) = Y Then 'Tant que la valeur du dessous est egale à celle-ci ..
i = i + 1 'on incremente i
Else
If i > 0 Then Application.DisplayAlerts = False: Y.Offset(-i, 0).Resize(i + 1).Merge: Application.DisplayAlerts = True 'si la valeur est differente => changement de date => fusion des cellules en fontion de i
Y.HorizontalAlignment = xlCenter 'Alignement
Y.VerticalAlignment = xlCenter 'Alignement
With Y.Offset(-i, 0).Resize(i + 1, NbCol) 'Encadrements
.Borders.Weight = xlMedium
.Borders(xlInsideVertical).Weight = xlThin
If i <> 0 Then .Borders(xlInsideHorizontal).Weight = xlThin
End With
i = 0
End If
Next Y
x.Range("A1").Resize(1, NbCol).EntireColumn.AutoFit
[COLOR="red"]End If[/COLOR]
Next x
Application.ScreenUpdating = True
End Sub

Je me pose aussi une question sur cette ligne :

If x.Range("A65536").End(xlUp).Row < 4 Then Exit For 'Si pas de données dans la colonne A on sort de la boucle

Vous êtes sûr qu'il faut sortir de la boucle ? Ne faut-il pas plutôt passer à la feuille suivante ??

A+

 

[job75]

Re : Formulaire de recherche

Re,

Il y a aussi une chose que j'ai du mal à saisir :

mon fichier "PROGRAMME OPERATOIRE GENERALE" ici celui de Aout10, est composé de 5 onglet

Quel est l'intérêt de faire un fichier par mois ?

Pourquoi ne pas faire un fichier par an qui comprendrait toutes les semaines (52 ou 53) de l'année ?

Avec la solution que j'ai proposée, la recherche se fait sur le mois choisi...

A+

 

[Tahititin]

Re : Formulaire de recherche

Bonjour Job75,
J'avais pensé (tout au début de ce projet) au fait de tout regrouper dans un seul fichier, mais à l'époque, le nombre d'onglet (52-53) nécessaires ajouté aux compétences informatiques succinctes de mes chères collègues utilisateurs m'y a fait renoncer.
Par contre, avec le formulaire de recherche que tu m'as gentiment créé, je pense que je vais reconsidérer tout ça…. Suite à ton dernier post j'ai même travaillé sur une maquette avec les 52 semaines de l'année que j'enverrais aux chefs de services pour approbation dès que le formulaire de recherche sera opérationnel…. Si ça fini par fonctionner !!!

J'ai en effet encore des soucis et bizarrement toujours dans la partie mise en forme du code, ce coup ci c'est un débogage : Erreur d'exécution 1004 à la ligne :
If i <> 0 Then .Borders(xlInsideHorizontal).Weight = xlThin
Pourtant il s'agit encore de mise en forme. Visiblement le problème viendrait de la semaine 35 (dernière semaine du mois).
J'ai tripoté un peu mais j'ai du mal à comprendre cette partie "mise en forme" du code : ce n'est pas moi qui l'ai fais.
Je trouve également que la macro synthèse est très (trop) lente comparé à la version initiale. J'ai fais des recherches sur le forum et visiblement, il n'y a pas grand-chose à faire !

A+

 

[job75]

Re : Formulaire de recherche

Bonjour Tahititin, le forum,

J'ai tripoté un peu mais j'ai du mal à comprendre cette partie "mise en forme" du code : ce n'est pas moi qui l'ai fais.

Peut-être, mais c'est vous qui profitez de ce fil pour nous la coller dans les pattes

Il faut fusionner les cellules après toutes les autres mises en forme :

Sub Test()
NbCol = 24 'Nombre de Colonnes de la base
ColServ = "I3" 'Cellule pour la 2eme clé de tri. Service ou Opérateur
'----------------------
Application.ScreenUpdating = False
For Each x In ThisWorkbook.Sheets 'Boucle sur les feuille du planning général
If x.Name <> "Recherche" Then x.Range("A4:T65536").Clear 'Efface les feuilles
Next
Chemin = ThisWorkbook.Path 'Définit le chemin des fichiers. Peut etre modifié ou rendu fixe => Chemin = C:\TOTO
Set Dossier = CreateObject("Scripting.FileSystemObject").GetFolder(Chemin) 'Définit le dossier d'ouverture des plannings
For Each Fichier In Dossier.Files 'Boucle sur les fichiers contenus dans le dossier
If Right(Fichier.Name, 3) = "xls" And Fichier.Name <> ThisWorkbook.Name Then 'Si ce sont des ".xls" et qu'ils sont differents de ce classeur alors ...
Set MonClass = Workbooks.Open(Chemin & "\" & Fichier.Name) 'On ouvre le classeur qu'on asscie à "MonClass"
For Each Feuille In MonClass.Sheets 'Boucle sur les feuilles de MonClass
If Left(Feuille.Name, 7) = "Semaine" Then 'si le nom commence par "Semaine" ...
'---------------- Modifié ici --------------------
For Each Cel In Feuille.Range("A4:A" & Feuille.Range("A65536").End(xlUp).Row + Feuille.Range("A65536").End(xlUp).MergeArea.Rows.Count - 1) 'Boucle sur les cellules de la colonne A
'-------------------------------------------------
If Cel.Offset(0, 1) <> "" Then 'Si la cellule NOM/Prénom est non vide ...
Set CelDest = ThisWorkbook.Sheets(Feuille.Name).Range("A65536").End(xlUp).Offset(1, 0)  'Définition de la cellule de destination. Derniere cellule vide
With CelDest
.Value = Cel.MergeArea.Resize(1, 1).Value 'récupération de la date
.Font.Bold = True 'formatage en Gras
.Font.Size = 14 'taille 14
End With
Cel.Offset(0, 1).Resize(, NbCol).Copy 'Copie de la ligne
CelDest.Offset(0, 1).PasteSpecial Paste:=xlPasteValues 'Collage valeurs
CelDest.Offset(0, 1).PasteSpecial Paste:=xlPasteFormats 'Collage formats
End If
Next Cel
End If
Next Feuille
MonClass.Close False 'Fermeture du classeur
End If
Next Fichier
'--------------- Mise en forme -------------------------------------
For Each x In ThisWorkbook.Sheets 'Boucle sur les feuilles du classeur
If x.Name <> "Recherche" Then
x.Range("A3").CurrentRegion.Offset(2, 0).Sort Key1:=x.Range("A3"), Order1:=xlAscending, Key2:=x.Range(ColServ), Order2:=xlAscending, Header:=xlYes 'tri par date et par Service (ou autre à défnir au début de la macro)
If x.Range("A65536").End(xlUp).Row < 4 Then Exit For 'Si pas de données dans la colonne A on sort de la boucle
For Each Y In x.Range("A4:" & x.Range("A65536").End(xlUp).Address) 'Boucle que la colonne A
If Y.Offset(1, 0) = Y Then 'Tant que la valeur du dessous est egale à celle-ci ..
i = i + 1 'on incremente i
Else
Y.HorizontalAlignment = xlCenter 'Alignement
Y.VerticalAlignment = xlCenter 'Alignement
With Y.Offset(-i, 0).Resize(i + 1, NbCol) 'Encadrements
.Borders.Weight = xlMedium
.Borders(xlInsideVertical).Weight = xlThin
If i > 0 Then .Borders(xlInsideHorizontal).Weight = xlThin: _
  [COLOR="Red"]Application.DisplayAlerts = False: .Resize(, 1).Merge: Application.DisplayAlerts = True 'si la valeur est differente => changement de date => fusion des cellules en fontion de i[/COLOR]
End With
i = 0
End If
Next Y
x.Range("A1").Resize(1, NbCol).EntireColumn.AutoFit
End If
Next x
Application.ScreenUpdating = True
End Sub

J'espère qu'il n'y aura pas d'autres surprises...

A+

 

[Tahititin]

Re : Formulaire de recherche

Job75,
Je suis bien conscient que j'use et abuse de ce forum pour vous refiler le BB. Mais j'aimerai vraiment pouvoir fournir à mes chèrs collègues un outils simple, intuitif et pratique. Pour information, j'ai été désigné d'office pour m'occuper de ce projet dans le cadre du regroupement de plusieurs blocs opératoires avec des fonctionnement trés trés différents.
Je suis désolé d'insister mais j'ai toujours cette ù*$^à d'erreur à la ligne :
If i > 0 Then .Borders(xlInsideHorizontal).Weight = xlThin

J'ai encore une fois tripoté, modifié, changer, réajuster... mais toujours cette erreur, qui bizarrement n'intervient pas avec le fichier d'origine.

Encore merci

 

[job75]

Re : Formulaire de recherche

Bonjour Tahititin, le forum,

J'ai bien testé ce morceau de code. Chez moi (Excel 2003) il n'y a jamais d'erreur, même en supprimant
If i > 0 Then.

... mais toujours cette erreur, qui bizarrement n'intervient pas avec le fichier d'origine.

Quelles différences y a-t-il donc avec le fichier d'origine ?

Quelle est la version Excel utilisée ?

Quel est le libellé complet de l'erreur 1004 ?

Prenez le fichier fautif et traitez-le en supprimant tout le code de mise en forme.

Ensuite déposez-le sur le fil avec sa macro, éventuellement sur cijoint.fr, en indiquant sur quelle cellule le code de mise en forme coince.

A+

 

[Tahititin]

Re : Formulaire de recherche

Bonjour Job75,

Quelles différences y a-t-il donc avec le fichier d'origine ?
Le fichier d'origine comporte 1 onglet par semaine (pour Aout : 5 onglets) et une macro qui va scanner plusieurs fichier pour les synthétiser. Les différences sont donc l'ajout d'un onglet recherche et dans le code quelques lignes qui isole l'onglet (If x.Name <>"Recherche" Then)

Quelle est la version Excel utilisée ? Excel 2007

Quel est le libellé complet de l'erreur 1004 ?
A la ligne : If i > 0 Then .Borders(xlInsideHorizontal).Weight = xlThin: _

Erreur d'exécution '1004' :
impossible de définir la propriété Weight de la classe Border​

Merci
A+

 

[job75]

Re : Formulaire de recherche

Bonjour Tahititin,

Ce qui est vraiment très curieux, c'est qu'il n'y a pas de problème sur :

.Borders(xlInsideVertical).Weight = xlThin

alors que ça coince sur :

If i > 0 Then .Borders(xlInsideHorizontal).Weight = xlThin

J'ai souvent vu que sur Excel 2007 il se passe des choses étranges...

Alors dernière tentative, ce code :

Sub Test()
NbCol = 24 'Nombre de Colonnes de la base
ColServ = "I3" 'Cellule pour la 2eme clé de tri. Service ou Opérateur
'----------------------
Application.ScreenUpdating = False
For Each x In ThisWorkbook.Sheets 'Boucle sur les feuille du planning général
If x.Name <> "Recherche" Then x.Range("A4:T65536").Clear 'Efface les feuilles
Next
Chemin = ThisWorkbook.Path 'Définit le chemin des fichiers. Peut etre modifié ou rendu fixe => Chemin = C:\TOTO
Set Dossier = CreateObject("Scripting.FileSystemObject").GetFolder(Chemin) 'Définit le dossier d'ouverture des plannings
For Each Fichier In Dossier.Files 'Boucle sur les fichiers contenus dans le dossier
If Right(Fichier.Name, 3) = "xls" And Fichier.Name <> ThisWorkbook.Name Then 'Si ce sont des ".xls" et qu'ils sont differents de ce classeur alors ...
Set MonClass = Workbooks.Open(Chemin & "\" & Fichier.Name) 'On ouvre le classeur qu'on asscie à "MonClass"
For Each Feuille In MonClass.Sheets 'Boucle sur les feuilles de MonClass
If Left(Feuille.Name, 7) = "Semaine" Then 'si le nom commence par "Semaine" ...
'---------------- Modifié ici --------------------
For Each Cel In Feuille.Range("A4:A" & Feuille.Range("A65536").End(xlUp).Row + Feuille.Range("A65536").End(xlUp).MergeArea.Rows.Count - 1) 'Boucle sur les cellules de la colonne A
'-------------------------------------------------
If Cel.Offset(0, 1) <> "" Then 'Si la cellule NOM/Prénom est non vide ...
Set CelDest = ThisWorkbook.Sheets(Feuille.Name).Range("A65536").End(xlUp).Offset(1, 0)  'Définition de la cellule de destination. Derniere cellule vide
With CelDest
.Value = Cel.MergeArea.Resize(1, 1).Value 'récupération de la date
.Font.Bold = True 'formatage en Gras
.Font.Size = 14 'taille 14
End With
Cel.Offset(0, 1).Resize(, NbCol).Copy 'Copie de la ligne
CelDest.Offset(0, 1).PasteSpecial Paste:=xlPasteValues 'Collage valeurs
CelDest.Offset(0, 1).PasteSpecial Paste:=xlPasteFormats 'Collage formats
End If
Next Cel
End If
Next Feuille
MonClass.Close False 'Fermeture du classeur
End If
Next Fichier
'--------------- Mise en forme -------------------------------------
For Each x In ThisWorkbook.Sheets 'Boucle sur les feuilles du classeur
If x.Name <> "Recherche" Then
x.Range("A3").CurrentRegion.Offset(2, 0).Sort Key1:=x.Range("A3"), Order1:=xlAscending, Key2:=x.Range(ColServ), Order2:=xlAscending, Header:=xlYes 'tri par date et par Service (ou autre à défnir au début de la macro)
If x.Range("A65536").End(xlUp).Row < 4 Then Exit For 'Si pas de données dans la colonne A on sort de la boucle
For Each Y In x.Range("A4:" & x.Range("A65536").End(xlUp).Address) 'Boucle que la colonne A
If Y.Offset(1, 0) = Y Then 'Tant que la valeur du dessous est egale à celle-ci ..
i = i + 1 'on incremente i
Else
Y.HorizontalAlignment = xlCenter 'Alignement
Y.VerticalAlignment = xlCenter 'Alignement
With Y.Offset(-i, 0).Resize(i + 1, NbCol) 'Encadrements
.Borders.Weight = xlMedium
.Borders(xlInsideVertical).Weight = xlThin
[COLOR="red"]If i > 0 Then .Borders(xlInsideHorizontal).LineStyle = xlContinuous: _
  .Borders(xlInsideHorizontal).Weight = xlThin: _
  Application.DisplayAlerts = False: .Resize(, 1).Merge: Application.DisplayAlerts = True 'si la valeur est differente => changement de date => fusion des cellules en fontion de i[/COLOR]
End With
i = 0
End If
Next Y
x.Range("A1").Resize(1, NbCol).EntireColumn.AutoFit
End If
Next x
Application.ScreenUpdating = True
End Sub

Par curiosité, mettez le code en rouge en commentaire et dites-nous : y a-t-il des bordures horizontales sur toutes les lignes de même date ?

A+

 

[Tahititin]

Re : Formulaire de recherche

Job75,
J'ai pris une grande décision ce matin : Supprimer tout simplement du code la fameuse ligne (If i > 0 Then .Borders(xlInsideHorizontal).Weight = xlThin: _) et, contrairement à il y a quelque jours... CA FONCTIONNE !! (nous sommes en plein dans la zone d'incertitude de l'informatique!!). Les cellules sont fusionnées, les bordures sont là sur toutes les ligne.

Par contre, suite à tes conseils, j'ai fais un test sur plusieurs mois (avec l'objectif à terme de pouvoir y intégrer les 52 semaines d'une année.
Tout fonctionne, il y a juste un petit bug : Je choisi un mois, puis un opérateur... j'ai bien la liste de ses intervention pour le mois selectionné. Par contre si je choisis un autre mois (pour le même opérateur sélectionné) j'ai un débogage : Erreur d'exécution 1004' : erreur définit par l'application ou par l'objet. Pour les autres items, pas de problème j'arrive à faire des recherches muticritère sans problème. il n'y a pque lorsque je souhaites changer de mois avec un opérateur déjà choisit.
En tout cas, quand ça marche, c'est magique !

Merci

 

[Tahititin]

Re : Formulaire de recherche

Job75,
Après mure réflexion, test, essais et avis demandé à mes collègues chirurgiens, les 52 semaines sur un même tableur risquent de poser des problèmes de compréhension et un "fouillis" qui en découragera plus d'un. On m'a donc demandé de rester sur 1 seul mois !
Est-il possible de présélectionner un mois ou de supprimer le combobox "mois" (tout en le laissant le mois visible) ? : Affichage de la listview1 avec en haut à gauche le mois d'aout (par ex) déjà sélectionner ?
Merci de ton aide... mes collègues chirurgien sont en effervescence, il adore le projet que je leur ai présenté ce matin (j'ai peaufiné tout ça dans la nuit !!)

A+

 

[job75]

Re : Formulaire de recherche

Bonjour Tahititin,

Procédons dans l'ordre.

1) Votre post #26.

Si l'on supprime .Borders(xlInsideHorizontal).Weight = xlThin qui crée le bug, il est bien normal qu'ensuite il n'y ait plus de bug...

Mais alors les bordures intérieures à droite des cellules fusionnées ne sont certainement pas Thin, mais Medium.

Avez-vous bien essayé la macro de mon post #25 et quel est le résultat ??

2) Il y avait bien un bug quand on changeait de mois avec la ComboBox2 renseignée.

J'ai donc modifié (légèrement) les macros des 3 fichiers de mon post #7, mettez à jour vos copies.

3) Votre post #27 sur les fichiers mensuels.

Avez-vous bien mesuré qu'un mois peut comporter 4, 5 ou 6 semaines, la 1ère et la dernière pouvant être à cheval sur 2 mois ?

Si l'on prend par exemple la semaine du 28/06/2010 au 02/07/2010, elle devra se trouver normalement à la fois dans le fichier du mois de juin et dans celui du mois de juillet...

Je trouve vraiment étrange de procéder ainsi alors que les semaines sont numérotées, et ce sera même une sérieuse source d'erreur si l'on fait des traitements sur l'ensemble des fichiers de l'année.

Enfin avoir 52 ou 53 onglets ne crée strictement aucune difficulté, surtout quand il y a un programme qui justement permet le tri par mois !!!

Néanmoins je ferai ce que vous voulez, mais en début de semaine prochaine.

Vous et vos collègues réfléchissez bien...

A+

 

[job75]

Re : Formulaire de recherche

Bonjour Tahititin,

Finalement j'ai trouvé le temps de faire le travail ce matin.

Voyez si ça vous convient.

A+

 

[job75]

Re : Formulaire de recherche

Rebonjour,

Je reviens sur la solution d'un fichier annuel.

Peut-être que revenir à chaque fois à la feuille "Recherche" vous rebute avec 52 feuilles ?

Alors voici une solution avec un petit UserForm "Recherche" qui se place en haut de la fenêtre.

Un clic sur son Label ouvre l'UserForm principal.

Il s'ouvre en "non modal" : on peut le laisser constamment ouvert, pendant qu'on travaille sur les feuilles ou dans l'autre UserForm.

Si on le ferme, on peut le rouvrir par le raccourci clavier Ctrl+A.

Nota : avec les fichiers joints, les ComboBox 2 et 3 ne s'effacent plus si l'on change de mois, amélioration des fichiers du post #7...

A+