Question fleuve

[Gruick]

Bonjour,

Un ministre de l'éducation dont le nom sera oublié va supprimer l'enseignement de l'histoire et géographie en terminale S.
Nos descendants ne sauront pas où situer la Romanche, affluent du Drac qui se jette dans l'Isère, laquelle donne ses eaux au Rhône.
Une amie enseignante m'a proposé un moyen synoptique de leur apprendre les fleuves et leurs affluents. Chose étrange, puisque j'y pensais, en regardant mes vieux cahiers conservés avec amour.

Banco ! lui dis-je.

Le fichier que j'envoie comporte une base de données, et des dessins de 4 fleuves coulant en France. (une feuille par fleuve)

Le but du jeu est de cliquer sur un nom de la BDD, et de le visualiser sur mes dessins en rouge au lieu de bleu par une macro événementielle.

Mais il y a un Hic ! Impossible de faire global. Si je veux trouver ma Romanche, je dois aller la chercher dans la feuille Rhône.
Je n'ai pas trouvé le moyen de faire une macro qui me dirait que si le nom n'est pas dans la feuille Seine, d'aller voir dans la Loire, ou la Garonne, ou le Rhône. Un truc du genre for each worksheet, ou with.

Mon fichier est incomplet, évidemment, et il manque des noms dans mes dessins, alors si une bonne âme...

Merci d'avance

 

[mromain]

Re : Question fleuve

Bonjour Gruick,

projet super intéressant

voici un essai :

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim s As Shape, f As Worksheet
nom = ActiveCell.Value
For Each f In Worksheets
    For Each s In f.Shapes
        s.Line.ForeColor.SchemeColor = 12
        If s.Name = nom Then
            s.Line.ForeColor.SchemeColor = 10
            f.Activate
            s.Select
        End If
    Next s
Next f
End Sub

a+

 

[pierrejean]

Re : Question fleuve

bonjour Gruick

Heureux de pouvoir t'aider

Vois si cela te convient

Edit: Salut mromain

 

[Gruick]

Re : Question fleuve

Merci mromain, hyper rapide

C'est vrai, c'est un travail de romain que j'ai entrepris, mais quand on aime...
Je teste illico.

Ca marche du tonnerre !

Comme j'ai chouchouté mon "Rhône", je poursuis sur les autres. La Seine, paradoxalement est très difficile, et les atlas sur internet sont assez rares.

Merci encore.

 

[Cousinhub]

Re : Question fleuve

Bonjour, tout le monde..

comme je l'ai fait également, voici ma proposition :

dans le code de la feuille :

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Target.Count > 1 Then Exit Sub
If Target.Column < 3 Then
    Call Coloriage_Fleuve(Target.Value)
End If
End Sub

et dans un module :

Sub Coloriage_Fleuve(LeFleuve As String)
Dim I As Byte
Dim J As Integer
Dim It
Dim Fleuve As Shape, Shp As Shape
Dim LesFleuves As Object
Set LesFleuves = CreateObject("Scripting.Dictionary")

For I = 2 To 5
    With Sheets(I)
        For Each Fleuve In .Shapes
            LesFleuves.Item(Fleuve.Name) = I
        Next Fleuve
    End With
Next I
For Each It In LesFleuves.keys
    If It = LeFleuve Then J = LesFleuves.Item(It): Exit For
Next It
If J = 0 Then Exit Sub
With Sheets(J)
    For Each Shp In .Shapes
        Shp.Line.ForeColor.SchemeColor = IIf(Shp.Name = It, 10, 12)
    Next Shp
    .Select
    .[A1] = LeFleuve
End With
End Sub

Je m'en vais découvrir vos solutions...

Bonne soirée à tous

 

[jeanpierre]

Re : Question fleuve

Bonjour Gruick, mromain, PierreJean,

Après quelques tests, beau travail de la part de Gruick et de Pierrejean.

Super.

Bonne journée.

Jean-Pierre

 

[Gruick]

Re : Question fleuve

Wouaou !

Ca vient de partout... je vais zieuter tout ça.
Quel succès, j'y croyais à peine, comme quoi.

Je vais aussi chercher à compléter mes lacunes via un atlas (et une loupe), parce que les cartes routières sont difficiles à lire quand on cherche un nom de rivière. La source de l'Oise m'a posé un gros problème par exemple, elle a même un affluent qui s'appelle le "Gland", et le "Petit Gland" ... qui ne figurent pas dans la BDD, mais que j'ai lu sur les cartes. Et le Rhône aussi, qui a deux "Ouvèze" de surcroît.

Pour les petiots, je vais en rester là, c'est déjà pas mal.

Je vais peut-être faire un appel au peuple pour les noms qui manquent sur les cartes, dans le salon XLD cette fois, car ce n'est plus du Excel pur.

Merci à tous.

 

[Gruick]

Re : Question fleuve

Bonjour,
Je reviens avec mes fleuves confinés déjà en page 11 du forum en 9 jours, quel succès pour le forum !!!
J'ai fait une macro qui, quand on clique sur un cours d'eau, me dit par un msgbox son nom, où il se jette, et sa longueur. Elle est censée colorier en rouge mon choix, et me msgboxer après. Or elle fait l'inverse, bien que l'instruction de coloriage soit placée avant.
Quid ? Y a-t-il une solution ou une explication ?

Précisions :
Certains cours ne sont pas encore répertoriés--->erreur
J'ai supprimé la Loire pour que le fichier "passe".

Cadeau :
Comme je suis un gros fainéant, j'ai fait une petite macro (Appel) qui m'affecte à chaque shape (préalablement nommée) la macro "rivière".

Merci, et joyeux Noël.

 

[PascalXLD]

Re : Question fleuve

Bonjour

c'est juste un problème de rafraichissement de page

Ajoute

Calculate

juste avant ton msgbox

 

[PascalXLD]

Re : Question fleuve

Re

Sinon j'ai oublié de te dire : Superbe boulot

 

[Guest]

Re : Question fleuve

Hello Gruick,

Ce décalage est une question de vitesse de temps d'exécution et de vitesse de rafraîchissement écran.

Vba allant plus vite à calculer il passe aux instructions suivantes avant d'avoir eu le temps de raffraichir l'écran.(ce qui se fait dans un autre processus).

ci dessous avec un time de 1 seconde (ce qui est long) vois comment tu peux le raccourcir.

Sub Rivière()
' Rivière Macro
' Macro enregistrée le 17/12/2009 par Gruick
Dim s As Shape, t
r = Application.Caller
With Sheets("BDD").Range("A:A")
    Set rr = .Find(r, lookat:=xlWhole)
    For Each s In ActiveSheet.Shapes
        s.Line.ForeColor.SchemeColor = 12
        If s.Name = rr Then s.Line.ForeColor.SchemeColor = 10
    Next s
End With
[B]t = Time()[/B]
[B]Do[/B]
[B]DoEvents[/B]
[B]Loop While Time() < t + TimeSerial(0, 0, 1)[/B]
MsgBox (rr.Value & vbLf & "se jette dans " & rr.Offset(0, 1) _
        & vbLf & "longueur " & rr.Offset(0, 2))
End Sub

Peut-être serait-il bon de tester application.caller pour savoir si la macro a été appelée par un shapes ou directement.

If TypeName(Application.Caller)<>"String" then Exit sub
Ou alors mettre Option Private Module en tête de module. Ou les deux.

Tester également rr
If not rr is nothing. (Pour les absents de la BDD)

A+

[Edition] Je viens de m'apercevoir qu'en mettant simplement
DoEvents
Sans timer cela le faisait quasi simultanément (la ligne se colorie en même temps que le msgbox appartait)

 

[Gruick]

Re : Question fleuve

Merci Pascal, Merci Hasco

Réponse tardive, je suis parti me goinfrer

J'avais effectivement pensé à "retarder" d'une énorme seconde.
J'ai pris finalement le DoEvents très approprié.
Pour les absents, j'ai mis On Error GoTo fin, en mettant fin: avant le end Sub. Je vais mettre un message pour améliorer, et un exit sub avant fin:

Je rassure tout le monde, la Loire est dans le premier fichier.

Il me vient l'idée de mettre quelques villes par la dessus, avec des "Ovals", mais ce sont aussi des shapes qui deviendraient bleus après la première sollicitation. Je ne sais pas si les Shapes sont identifiables par un type, sinon je demanderai de ne pas changer leur couleur. Je compléterai ainsi la bdd par les villes que traversent mes rivières.
En cliquant dessus, par une macro ville, je saurai son nom et la rivière qui la traverse. Mais bon, j'en suis pas là, les mouflets ne savent même plus où situer Rouen, alors...

Merci encore

 

[Guest]

Re : Question fleuve

Re,

Tu pourras identifier tes 'ovals' en mettant quelque chose de commun dans leur nom.

J'espère que tu feras partagé le classeur final. C'est très chouette ton idée.

A+++

 

[pierrejean]

Re : Question fleuve

bonjour a tous
Pour ma part j'ai fait ceci

Sub Rivière()
' Rivière Macro
' Macro enregistrée le 17/12/2009 par Gruick
Dim s As Shape
[COLOR=blue]Application.ScreenUpdating = False
[/COLOR]r = Application.Caller
With Sheets("BDD").Range("A:A")
    Set rr = .Find(r, lookat:=xlWhole)
    For Each s In ActiveSheet.Shapes
        s.Line.ForeColor.SchemeColor = 12
        If s.Name = rr Then s.Line.ForeColor.SchemeColor = 10
    Next s
End With
[COLOR=blue]Application.ScreenUpdating = True
[/COLOR]MsgBox (rr.Value & vbLf & "se jette dans " & rr.Offset(0, 1) _
        & vbLf & "longueur " & rr.Offset(0, 2))
End Sub

 

[Gruick]

Re : Question fleuve

Bonne idée Hasco...

...du genre •Rouen, •Vizille, •Lyon, •Challans, •Rennes, •Vernon, •Nouméa (euh, si j'en trouve un autre en Métropole) pour rendre hommage aux participants de ce fil...

Tiens, Salut Pierre

Pour le partage déjà, le fichier est exploitable tel quel. Je pense y ajouter les fleuves côtiers du genre Somme, Ille, Charente, Adour, Hérault, Var et la Veules et son 1,19 km de long.

Purée, dans quoi je me suis lancé... il met un pied dans l'eau...
Bon, arrête de grommeler Gruick, tu l'a voulu, maintenant au boulot...

A plus, toutes les bonnes idées sont bienvenues.