Calcul distance et temps entre deux adresses multiples ligne

Bonjour,

Voilà je vient de trouver comment faire mes calculs de distance et de temps entre deux adresses, cependant je dois rentrer les données en B1 et B2 du fichier "calcul distance" pour obtenir en B5 les km et en B6 le temps

Je souhaiterais appliquer cette macro ou un équivalent au deuxième fichier joint "fichier client"

Dans ce fichier lorsqu'en colonne G apparait OUI je souhaite calculer le temps et les kilomètre entre l'adresse de cette ligne et la précédente

Dans cet exemple:

G3 = OUI donc je souhaite calculer les km qui s'afficheront en H3 et le temps en I3. L'adresse de départ se trouvant en D2 et celle de l'arrivée en D3

Il faut qu'a chaque fois qu'il y ai un OUI en G la macro réagisse comme ça (adresse ligne d'avant à l'adresse de la ligne)

Quelqu'un peut m'éclairer ?

Bonjour Fiorina,

voici un premier jet, largement améliorable.

Merci à H2SO4 pour la mise au point de cette magnifique macro que je garde précieusement en réserve.

A+

Je comprend c'est lui qui m'a aidé a faire le fichier calcul distance.

J'ai compris ou tu l'as intégré, j'ai remarqué les changements dans le code par contre ça ne marche pas aucune colonne ne se remplis en colone H et I

ben, ici, ça fonctionne nickel!

Je ne sais pas quoi te dire...

8)

A+

Salut

J'ai trouvé comment faire pour que ça marche: Il faut que je tape OUI manuellement dans la colonne G et la c'est vrai que ça fonctionne. Le problème c'est que dans cette colonne G il y a une formule qui détermine de mettre OUI ou laisser blanc. Je pense donc que c'est à ce niveau que ça beug. Peut être dois je mettre la colonne en forme particulière?

Bonsoir,

comme ceci alors...

Private Sub Worksheet_Calculate()
'
Dim iRow As Integer
'
iRow = CInt([AA1])
If Cells(iRow, 7) = "OUI" Then
    If iRow > 2 And Range("D" & iRow) <> "" Then Call InitCalc(iRow)
Else
    Range("H" & iRow & ":I" & iRow) = ""
End If
'
End Sub

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
'
[AA1] = Target.Row
'
End Sub

Je suis en train, cool 8) hein! , de te pondre un petit truc avec préparation d'agenda, mise à jour de ta feuille 'Prestations' avec le programme du jour selon agenda, BDD clients, archives prestations...

Je continue ou tu n'en as pas besoin?

A+

La classe ...

Vas y continue ça m’intéresse.

Pour ce code, je le remplace par l’ancien sur la feuille prestations?

Bonjour Fiorina,

à remplacer dans 'Prestations'.

Tu laisses évidemment :

• InitCalc() ;
• GoogleGetRoute() ;
• fctSwapChr()

OK, je continue. Patience!

A+

Pas de problème et merci.

J'ai donc gardé

• InitCalc() ;
• GoogleGetRoute() ;
• fctSwapChr()

Pour l'instant les constatations c’est qu'en colonne G se met un OUI automatiquement mais ne respecte plus ma formule. Cependant quand le Oui s'inscrit la recherche TPS et KM fonctionne

Afin d'apporter des explications à cette formule en G:

Le but est qu'un OUI se met lorsqu'il y a 30 min maximum entre deux clients (entre F et B) : cas pour obtenir une indemnité de transport

Salut Fiorina,

La formule en VBA qui contrôle, en plus, qu'il y ait bien des adresses à calculer...

Pour tester, tu gardes les macros InitCalc(), GoogleGetRoute() et fctSwapChr(), tu vires les formules en [G:G] (optimiste, toi! 5000 prestations potentielles! Cool! ) et tu colles ceci :

Private Sub Worksheet_Change(ByVal Target As Range)
'
Dim dDiff As Double
'
Application.EnableEvents = False
'
If Not Intersect(Target, Range("B:B")) Is Nothing Then
    iRow = Target.Row
    Cells(iRow, 7) = ""
    Range("H" & iRow & ":I" & iRow) = ""
    If iRow > 2 And Cells(iRow, 4) <> "" And Cells(iRow - 1, 4) <> "" And Cells(iRow - 1, 1) = Cells(iRow, 1) Then
        dDiff = Format(Cells(iRow, 2) - Cells(iRow - 1, 6), "####0.0000")
        Cells(iRow, 7) = IIf(dDiff < 0.0215, "OUI", "NON")
        If Cells(iRow, 7) = "OUI" Then Call InitCalc(iRow)
    End If
End If
'
Application.EnableEvents = True
'
End Sub

A+

Bon ben après un premier test ça a l’air de marcher parfaitement.

Ce soir j’aurais plus le temps de le mettre en application et je te dit ca.

Dans tous les cas je voulais te dire merci ça m’aide beaucoup...

Avec plaisir!

8)

A+

Curulis

Je reviens vers toi car aprés de nombreux test je m'aperçois que ça ne marche pas parfaitement je m'explique:

Sur la page résumé des prestations, je m'aperçois qu'en rajoutant l'acte tout se met bien à la place sauf (moins de 30 min) le OUI et les données KM et TPS alors que ça devrait apparaitre. Le seul moyen de faire apparaitre ses données est de sélectionner la case colonne B (de la ligne qui ne marche pas) et de valider par la touche entrée. Là tout apparait.

Je glisse le fichier pour te faire une idée

En espérant qu'on puisse trouver une solution

Salut Fiorina,

voilà ta macro à placer dans le Module1.

Prends soin de migrer InitCalc(), fctSwapChr(), GoogleGetRoute() vers le Module1.

Donc, en théorie, le Module2 sera vide : élimine-le. Aucune besoin de les multiplier!

Sub AjouterPrestation()
'
Application.ScreenUpdating = False
'
With Sheets("Résumé des prestations")
    iRow = .Range("A" & Rows.Count).End(xlUp).Row + 1
    .Range("A" & iRow).Value = Range("E7").Value
    .Range("B" & iRow).Value = Range("E11").Value
    .Range("C" & iRow).Value = Range("H9").Value
    .Range("E" & iRow).Value = Range("H13").Value
    .Range("K" & iRow).Value = Range("D9").Value
    .Range("J" & iRow).Value = Range("D14").Value
    '
    .Cells(iRow, 7) = ""
    .Range("H" & iRow & ":I" & iRow) = ""
    If iRow > 2 And .Cells(iRow, 4) <> "" And .Cells(iRow - 1, 4) <> "" And .Cells(iRow - 1, 1) = .Cells(iRow, 1) Then
        dDiff = Format(.Cells(iRow, 2) - .Cells(iRow - 1, 6), "####0.0000")
        .Cells(iRow, 7) = IIf(dDiff < 0.0215, "OUI", "NON")
        If .Cells(iRow, 7) = "OUI" Then Call InitCalc(iRow)
    End If
End With
'
Application.ScreenUpdating = True
'
End Sub

A+

Salut

J'ai bien fait les opérations demandées et on y est presque!

Maintenant tout se place bien sur le résumé des prestations km - tps - oui - etc. J'ai juste essayé de modifié une petite chose que tu n'as pas intégré dans le dernier code : supprimer 3 cellules à la fin de la macro. Dans mon code de base la macro aprés avoir copié la cellule E11, H9 et H13 supprime le contenu pour facilité le remplissage de la prochaine prestation.

J'ai donc rajouté :

.Range("E11").ClearContents

.Range("H9").ClearContents

.Range("H13").ClearContents

Mais ca ne marche pas ça ne les supprime pas.

Une autre chose sur l'onglet "résume des prestations" qui m'embête et qui vient de me monter à l'esprit:

Est il possible de rajouter dans ce dernier code un tri personnalisé? A chaque validation de la macro et aprés avoir fait tout le travail que la colonne A (date) soit par ordre croissant puis la colonne B (Heure Arrivée) ainsi les prestations même rentrées dans le désordre

se remettraient bien et aucune erreur ne seraient possible (les km et tps seront pour les bonnes adresses du coup car si il n'y a pas se tri et qu'une prestation est rentrée dans le désordre, ca fausse tout.

Un autre soucis que je ne comprend pas. Lors de l'ajout d'un client (macro du module 1 à la base) lors de la validation la macro m'affiche la page "fichier client" (endroit ou elle place le contenu de C19 et H19 avant de les effacés) malgré avoir mis le screenupdating en arrêt, sais tu pourquoi??? C'est justement à la suite de ce code que j'ai tout collé comme demandé. Voici le code:

Sub AjouterClient()

Application.ScreenUpdating = False

Sheets("Fichier client").Select

Rows("4:4").Select

Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove

Sheets(1).Range("C19").Copy

Sheets("Fichier client").Range("B4").PasteSpecial Paste:=xlPasteValues ', Operation:=xlNone, SkipBlanks

Sheets(1).Range("C19").ClearContents

Sheets(1).Range("H19").Copy

Sheets("Fichier client").Range("C4").PasteSpecial Paste:=xlPasteValues ', Operation:=xlNone, SkipBlanks

Sheets(1).Range("H19").ClearContents

Application.ScreenUpdating = True

End Sub

Dans ce code je créé une ligne entre les deux basiques afin que se qui se rajoute apparaisse dans le menu déroulant de la case H9 "A remplir"

Je remet le fichier avec les dernières modifications au cas ou il y en aurait besoin

Encore mille merci pour toute cette aide

Salut Fiorina,

voilà les corrections demandées... sauf ton tri des prestations.

Je ne comprends comment tu pourrais les rentrer "dans le désordre"?

Pour le reste, tu colles les nouvelles macros en lieu et place des autres.

Sub AjouterPrestation()
'
Dim sWkA As Worksheet
Set sWkA = Worksheets("A Remplir")
'
Application.ScreenUpdating = False
'
With Sheets("Résumé des prestations")
    iRow = .Range("A" & Rows.Count).End(xlUp).Row + 1
    .Range("A" & iRow).Value = sWkA.Range("E7").Value
    .Range("B" & iRow).Value = sWkA.Range("E11").Value
    .Range("C" & iRow).Value = sWkA.Range("H9").Value
    .Range("E" & iRow).Value = sWkA.Range("H13").Value
    .Range("K" & iRow).Value = sWkA.Range("D9").Value
    .Range("J" & iRow).Value = sWkA.Range("D14").Value
    '
    .Cells(iRow, 7) = ""
    .Range("H" & iRow & ":I" & iRow) = ""
    If iRow > 2 And .Cells(iRow, 4) <> "" And .Cells(iRow - 1, 4) <> "" And .Cells(iRow - 1, 1) = .Cells(iRow, 1) Then
        dDiff = Format(.Cells(iRow, 2) - .Cells(iRow - 1, 6), "####0.0000")
        .Cells(iRow, 7) = IIf(dDiff < 0.0215, "OUI", "NON")
        If .Cells(iRow, 7) = "OUI" Then Call InitCalc(iRow)
    End If
End With
sWkA.Range("E11").Value = ""
sWkA.Range("H9").Value = ""
sWkA.Range("H13").Value = ""
'
Application.ScreenUpdating = True
'
End Sub

Sub AjouterClient()
'
Dim sWkA
Set sWkA = Worksheets("A remplir")
'
With Worksheets("Fichier client")
    .Range("A4").EntireRow.Insert Shift:=xlDown
    .Range("B4").Value = sWkA.Range("C19")
    .Range("C4").Value = sWkA.Range("E19")
    iRow = .Range("B" & Rows.Count).End(xlUp).Row
    .Range("B4:C" & iRow).Sort key1:=.Range("B4"), order1:=xlAscending, Orientation:=xlTopToBottom
End With
sWkA.Range("C19") = ""
sWkA.Range("E19") = ""
'
End Sub

A+

Salut

Le tri personnalisé car il pourrait y avoir un oubli mais je me dit qu’après une erreur on s'en aperçoit et on peut faire la modification à la main gardant le résumé des prestations à côté.

Bon j'ai beau tout essayé, je ne peux que constater que tout fonctionne parfaitement bien. Grace à cette expérience en partie dû a Curulis57 (j'adore le 57 c'est mon département), j'ai beaucoup appris et j'ai réussi à comprendre en partis tout se que j'ai pu copié. Avec tout ça je pense que nous avons créé la macro pour les auxiliaire de vie utilisable pour toutes. Il me manque plus qu'à finaliser les fiches de paie (onglet Janvier à Décembre) que restent générales et donc adaptable à toutes les années et se sera parfait.

Afin de faire profité tout le monde de savoir et de l'investissement de Curulis57, je poste le fichier final qui peut être servira à d'autre.

Je le redis donc: "Mille merci Curulis57" et à trés vite je pense car mon prochain POST risque de te plaire, je pense t'y retrouver la bas car c'est un projet simple mais de grande envergure qui si je le résoud sera utilisé au nationnal dans ma société. Encore merci

Bonjour

Je reviens à la charge, j'ai enfin mis tout en forme et j'ai commencé à utiliser le fichier, c'est là que les premiers problèmes sont survenu:

- Les kilomètres recherchés automatiquement et inscrit dans "Résumé des prestations" sont stockés sous forme de TEXTE, je ne peux donc pas les utiliser pour les additionnés (voir fiche de paie d'octobre les autres sont vérouillés). Je suis donc obligé de les convertir manuellement en nombre pour pouvoir les utiliser

- Mes menus déroulant dans l'onglet "A remplir" me posent un problème:

Je ne peut pas naviguer avec la molette de la sourie, je suis contraint de jouer avec la barre sur le côté droit pour descendre et monter. Encore pire, je ne peux pas écrire l'heure ou le nom malgré que je note comme enregistré. Y a t il une solution à ce niveau ?

- Autre soucis au niveau de la macro même:

Lors de la validation via le bouton "Enregistrer la prestation", une page blanche s'ouvre et se referme une ou deux fois ça dépend des moments. Pour ce qui est des deux fonctions de la macro "Enregistrer la prestation" ou "Ajouter le client" la macro est trés lente et avec ses problèmes les saisies et enregistrement deviennent fastidieux et long

Je tiens a préciser qu'a part l'onglet "Fichier client" la plupart des onglet sont totalement vérouillés (fiche de paie) et les autres comportent simplement certaines cellules vérouillées ( colone D et F dans "Résumé des prestations") ceci est important pour ne pas fausser les formules par un utilisateur avec peut de connaissances.

J'espère vraiment qu'on va réussir à améliorer ça car on y est presque !!!

Je glisse le fichier

J'avance un peu de mon côté et j'ai trouvé une solution qui n'est pas complète mais change un peu les choses

C'est au niveau des menus déroulant:

J'ai créé une liste nommé ce qui fait que désormais je peux rajouter à la suite des noms de clients et il se rajoutent dans le menu déroulant à la suite. Ca m'arrange pour le reste du fichier car jusqu'à présent ma macro rajouter une ligne entre les deux de base (pour se qui est de rajouter un client) ce qui me permettais d'avoir un menu déroulant toujours à jour mais me bloque pour d'autre action. Je peux donc modifier la macro SUIVANTE:

Sub AjouterClient()

'

Dim sWkA

Set sWkA = Worksheets("A remplir")

'

With Worksheets("Fichier client")

.Range("A4").EntireRow.Insert Shift:=xlDown

.Range("B4").Value = sWkA.Range("C19")

.Range("C4").Value = sWkA.Range("H19")

iRow = .Range("B" & Rows.Count).End(xlUp).Row

.Range("B4:C" & iRow).Sort key1:=.Range("B4"), order1:=xlAscending, Orientation:=xlTopToBottom

End With

sWkA.Range("C19") = ""

sWkA.Range("H19") = ""

'

End Sub

Celle ci rajoute une ligne 4 et colle le nom en B4 et l'adresse en C4, je dois maintenant coller le nom en B et l'adresse en C mais à la suite des précédent

Sauriez vous modifier ce code pour mettre tout a la suite au fure et a mesure que je rentre les noms et adresses ?

Pour en revenir à la liste nommé, ça pause problème dans le menu déroulant, je m'explique:

Dans l'onglet "A remplir" case H9 ou se trouve le menu déroulant nommé les clients ajouté à la suite se rajoute bien, je peux comme voulu entrer le nom du client à la main, le problème c'est qu'on ne m'interdit pas de faire une faute, je peux ecrire désormais ce que je veux et donc faire des erreurs, il faudrait que je n'ai le choix que de taper un des noms de la liste et qu'un message d'erreur apparaisse si le nom n'est pas dans la liste,

Sauriez vous comment faire ?

Salut Fiorina,

un mot de passe m'empêche d'accéder au programme!

A+