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

 

[Gruick]

Re : Question fleuve

Bonjour,

Le réveillon de Noël est-il bien digéré ?

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

Hasco dixit

En utilisant TypeName(selection), instruction géniale que tu as évoquée, cela me donne "Oval", le voilà le point commun !
Ce n'était pas plus dur que ça, mais fallait y penser. Merci Hasco.
Donc, si ma Shape est Oval (Ellipse en Français) diriges-toi sur une macro "Ville" sinon, "Rivière".

J'ai testé sur Lyon arrosé par le Rhône et la Saône, et Grenoble où coulent l'Isère et le Drac. Ca marche Impeccablement.

Bonnes fêtes de fin d'année à tous.

 

[Guest]

Re : Question fleuve

Hello Gruick,


J'ai sorti le groin de l'assiette. Les fermiers avaient préparé une 'pâtée' divine pour nos auges....

A part cela,
Dans ce cas, non seulement je testerai avec TypeName(LaChose) mais aussi sur le nom. Que j'aurais créé moi-même. Tu ne sais pas si d'autres 'Ellipse' 'Ovals' vont être ultérieurement créés pas l'utilisateur. Ou d'anciens qu'on aurait oubliés de nettoyer.

A+

 

[Staple1600]

Re : Question fleuve

Bonjour à tous



Sauf erreur de ma part

Avec AutoShapeType

Sub test()
Dim s As Shape
For Each s In ActiveSheet.Shapes
MsgBox s.AutoShapeType
Next
End Sub

Pour une Elllipse la MsgBox renvoie : 9

Mais est-ce que 9 est seulement renvoyé par un ovale , ca je ne sais pas.

 

[Guest]

Re : Question fleuve

Re tout le monde

Hey, hey, l'ami Staple, te re-voilà, bien content de te croiser. Bonnes fêtes de fin d'année

A+

 

[Staple1600]

Re : Question fleuve

Re


Bonjour Hasco (content également de te croiser)

Bonnes fêtes à toi et à tous

Alors AutoShapeType , j'ai faux ou j'ai bon ?

 

[Guest]

Re : Question fleuve

Re,

Tout à fait bon. AutoShapeType = 9 = msoShapeOval

A++

Au fait, je n'ai salué, ni Pascal, ni Hubert, ni mRomain,ni Pierre-jean
A qui j'adresse d'amicales pensées.

 

[Cousinhub]

Re : Question fleuve

Hi, Ges....

Au fait, je n'ai salué, ni Pascal, ni Hubert, ni mRomain,ni Pierre-jean

Pour ma part, c'est pas gênant, ma solution est passée inaperçue....

Meilleurs voeux, à tous

Au plaisir

Edit, j'aurais pas du dire "solution", mais plutôt, "proposition", scusez.....

 

[Gruick]

Re : Question fleuve

re,

Et oui, ça bosse aussi le dimanche chez XLD.
En plus, je craignais une petite baisse entre les fêtes (et non pas... )

La macro pour affecter les macros aux shapes devient :

Sub Appel()
Dim chap As Shapes
For Each chit In Sheets
  If chit.Name <> "bdd" Then
    For n = 1 To chit.Shapes.Count
      chit.Select
      chit.Shapes(n).Select
      If TypeName(Selection) <> "Oval" Then
        Selection.OnAction = "Rivière"
      Else
        Selection.OnAction = "Ville"
      End If
    Next
  End If
Next
End Sub

et pour les villes :

Sub Ville()
Dim vv
v = Application.Caller
vil = v & vbLf & "traversée par : " & vbLf
With Sheets("bdd").Range("H:Z")
  Set vv = .Find(v, LookIn:=xlValues)
  If Not vv Is Nothing Then
    firstAddress = vv.Address
    Do
      vil = vil & Sheets("bdd").Cells(vv.Row, 1) & vbLf
      Set vv = .FindNext(vv)
    Loop While Not vv Is Nothing And vv.Address <> firstAddress
  End If
End With
MsgBox vil
End Sub

En mettant le nom des villes (une par cellule) sur la bdd à partir de la colonne H en face de la (ou les) rivière(s) qui l'arrose, et en nommant chaque ellipse dessinée.
Je ne connaissais pas AutoShapeType, ni TypeName() avant ce fil, donc encore merci.

 

[Gruick]

Re : Question fleuve

Bonjour et bonne Année 2010,

Je peaufine peu à peu mon dossier, mais je me suis aperçu d'un truc auquel j'aimerai remédier. Je vais commencer les fleuves côtiers comme la Somme, la Charente, etc... sur une carte de France.

Mon "Rhône" par exemple est tout en hauteur, et je ne le vois que partiellement à l'écran, sauf si je zoome à 50 %, et dans ce cas, ça devient assez dur à faire fonctionner.
Ma rivière sélectionnée dans la bdd lance la macro événementielle, et me colorie en rouge la rivière trouvée.
Le hic est que quelquefois, ma rivière "sort" de l'écran.

Est-il possible de "centrer" à l'écran la rivière trouvée. (par macro).

Vos suggestions seront les bienvenues, et mes remerciements anticipés vous sont d'ores et déjà adressés.

Gruick

 

[pierrejean]

Re : Question fleuve

bonjour a tous et meilleurs voeux pour 2010

Une 1ere approche

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
'Dim s As Shape
'nom = ActiveCell.Value
'Sheets("Seine").Activate
'For Each s In ActiveSheet.Shapes
    's.Select
    'Selection.ShapeRange.Line.ForeColor.SchemeColor = 12
'Next
'ActiveSheet.Shapes(nom).Select
'Selection.ShapeRange.Line.ForeColor.SchemeColor = 10
'ActiveSheet.Cells(1, 1).Select
'Selection = nom
If Target.Column = 1 Or Target.Column = 2 Then
For Each sh In Sheets
  If sh.Name <> "bdd" Then
  Application.ScreenUpdating = False
    For n = 1 To sh.Shapes.Count
         sh.Select
         sh.Shapes(n).Select
         Selection.ShapeRange.Line.ForeColor.SchemeColor = 12
      If sh.Shapes(n).Name = Target.Value Then
         Selection.ShapeRange.Line.ForeColor.SchemeColor = 10
         ActiveSheet.Cells(1, 1).Select
         trouve = True
         GoTo fin
      End If
    Next n
  End If
Next sh
End If
fin:
If Not trouve Then
 Sheets("bdd").Select
 MsgBox ("Pas encore repertorié")
Else
[COLOR=blue]Call test1(Target.Value)[/COLOR]
End If
Application.ScreenUpdating = True
End Sub
 
 
[COLOR=blue]Sub test1(Riv)[/COLOR]
[COLOR=blue]ActiveSheet.Shapes(Riv).Select[/COLOR]
[COLOR=blue]taillepage = ActiveSheet.Rows(1).Height * 34[/COLOR]
[COLOR=blue]ActiveWindow.Zoom = Int(taillepage * 95 / Selection.Height)[/COLOR]
[COLOR=blue]ActiveWindow.ScrollRow = Selection.Top / ActiveSheet.Rows(1).Height[/COLOR]
[COLOR=blue]End Sub[/COLOR]

C'est valable pour le Rhone et la Loire par contre il faudra aussi adapter en largeur et eventuellement limiter le zoom pour les petites rivieres

 

[pierrejean]

Re : Question fleuve

Re

A tester plus avant

Sub test1(Riv)
 ActiveSheet.Shapes(Riv).Select
 taillepage = ActiveSheet.Rows(1).Height * 34
 Zoom = Int(taillepage * 95 / Selection.Height)
 If Zoom > 200 Then Zoom = 200
 ActiveWindow.Zoom = Zoom
 ActiveWindow.ScrollRow = Int(Selection.Top / ActiveSheet.Rows(1).Height)
 If Int(Selection.Left / ActiveSheet.Columns(1).Width) > 0 Then
   ActiveWindow.ScrollColumn = Int(Selection.Left / ActiveSheet.Columns(1).Width)
 End If
End Sub

 

[Gruick]

Re : Question fleuve

Bonsoir Pierre, et bonne année

J'ai du m'absenter, et je suis resté connecté sur XLD en mon abscence.
J'ai trouvé une instruction

Sh.Shapes(n).TopLeftCell.Address (vérifié par un msgbox espion)

qui me donne une adresse $C$10 pour le Doubs. (Coin supérieur gauche). De là il suffirait paraît-il de sélectionner cette cellule, mais là, je ne sais pas.
Range("$C$10").select ne marche pas.

A l'aide....



Edit :
Trouvé ceci :
Application.Goto Reference:=Sh.Shapes(n).TopLeftCell, scroll:=True

mais ça me fixe en haut à gauche, pas terrible.

 

[mromain]

Re : Question fleuve

Bonjour le fil et bonne année,

voici un essai :

Sub test()
Dim laShape As Shape, celluleCentre As Range, centreT As Double, centreL As Double, i As Long
Dim nbColAffichees As Long, nbLigAffichees As Long, decalageCol As Long, decalageLig As Long

'définir la forme
Set laShape = Sheets("Feuil1").Shapes("Forme libre 1")

'calculer les "coordonnées" du centre de la forme
centreT = laShape.Top + laShape.Height / 2
centreL = laShape.Left + laShape.Width / 2

'calculer la cellule correspondante aux "coordonnées"
Set celluleCentre = Sheets("Feuil1").Range("A1")
    
While celluleCentre.Offset(0, 1).Left < centreL
    Set celluleCentre = celluleCentre.Offset(0, 1)
Wend
While celluleCentre.Offset(1, 0).Top < centreT
    Set celluleCentre = celluleCentre.Offset(1, 0)
Wend

'vériffier le nombre de lignes et colonnes affichées
nbColAffichees = ActiveWindow.VisibleRange.Columns.Count
nbLigAffichees = ActiveWindow.VisibleRange.Rows.Count

'calculer la cellule (colonne et ligne) à afficher en haut à droite
decalageCol = IIf(celluleCentre.Column - CInt(nbColAffichees / 2) + 1 < 1, 1, celluleCentre.Column - CInt(nbColAffichees / 2) + 1)
decalageLig = IIf(celluleCentre.Row - CInt(nbLigAffichees / 2) + 1 < 1, 1, celluleCentre.Row - CInt(nbLigAffichees / 2) + 1)

'positionner la fenêtre (bugge depuis VBE, la macro doit être lancée depuis le excel)
ActiveWindow.ScrollColumn = decalageCol
ActiveWindow.ScrollRow = decalageLig
End Sub

voir le classeur en PJ


a+

 

[pierrejean]

Re : Question fleuve

Re

Mon ami Gruick

As-tu testé ma proposition ?

 

[Gruick]

Re : Question fleuve

Bonjour Pierre, bonjour Romain.

Un peu occupé ces jours ci, pardon pour ma réponse tardive.

@Pierre,
J'ai testé, ok sur le Rhône, mon favori, je me baignais dans la Dranse d'Abondance quand j'étais môme, et la Séveraisse, puis la Romanche vers Vizille pays de mes ancètres maternels, et cet été dans le Verdon, et aux sources de l'Argens.
Mais la Seine où je vis me pose des problèmes, la Lézarde, l'Oise sortent du cadre... comprends pas.
Peut-être les calculs effectués sont bloqués quand ils dépassent ???

@Romain,
Je vais voir ta solution, elle est rétive sur le Mac, mais devrait aller sur mon PC avec XL2000.
Je te tiens au courant.

@Gruick
Ben mon cochon, t'es pas au bout de tes peines !