Code boucle pour remplir les cellules d'un tableau

jenny-eg Messages postés 10 Statut Membre -  
cs_Le Pivert Messages postés 8437 Statut Contributeur -
Bonjour,
j'ai un code pour chercher automatiquement la distance entre deux villes dans la feuille 2 du fichier joint.
Mon but est de remplir la feuille 1.

(J'avais pensé à la remplir avec un sommeprod feuille 2, 1ere ligne et 1 ere colonne mais je pense que mon fichier va avoir un pb de calcul de processeur...)

Donc j'ai pensé à mettre le code directement sur la feuille 1 pour qu'il remplisse les distances avec le code dans le corps du tableau.
Mais je pense que mon code ne va pas apprécier quand il va arriver aux cellules en noir car c'est la même ville de départ et de destination...

Etant novice en VBA j'ai un peu de mal avec les boucles. HELP

https://www.cjoint.com/c/KIkiGvJ7AGJ

2 réponses

  1.
    cs_Le Pivert Messages postés 8437 Statut Contributeur 730
     
    Bonjour,

    voici le code. L'exécution est très longue 5 mn 

    Option Explicit
'Déclaration d'une constante:
Public Const DIST = "http://www.distance2villes.com/recherche?source="  'URL SITE WEB
Sub boucleville()
Dim FL1 As Worksheet, NoCol As Integer
Dim NoLig As Long
Dim URL As String, TXT As String
Dim VilleDepart As String, VilleDestination As String
    Set FL1 = Worksheets("Feuil2")
    NoCol = 1 'lecture de la colonne A
    'Application.ScreenUpdating = False ' a mettre pour ne pas voir défiler
    On Error Resume Next
    For NoLig = 2 To Split(FL1.UsedRange.Address, "$")(4)
        VilleDepart = FL1.Cells(NoLig, NoCol)
        VilleDestination = Cells(NoLig, NoCol + 1)
        If VilleDepart = "" Then Exit Sub
With ActiveSheet
'construction du lien
URL = DIST & VilleDepart & "&destination=" & VilleDestination
With CreateObject("WinHTTP.WinHTTPRequest.5.1")
.Open "GET", URL, False
.Send
TXT = .ResponseText
End With
'extraction nbre km
Range("C" & NoLig) = Split(Split(TXT, "id=""distanciaRuta"">")(1), "</strong>")(0)
'on recupere durée trajet
Range("D" & NoLig) = Split(Split(TXT, "id=""tiempo"">")(1), "</span></strong>")(0)
'on recupere lien Url transforme en lien hypertexte
'Range("E" & NoLig) = URL
'.Hyperlinks.Add .Range("E" & NoLig), URL
End With
    Next
    Set FL1 = Nothing
    'Application.ScreenUpdating = True 'retablir
End Sub


    si tu ne veux pas voir la progression active cette ligne: 

    Application.ScreenUpdating = False ' a mettre pour ne pas voir défiler


    et celle ci: 

    Application.ScreenUpdating = True 'retablir


    0
  2. jenny-eg Messages postés 10 Statut Membre
     
    Bonjour Mr le Pivert,

    Merci beaucoup cela fonctionne et j'avais vraiment un problème pour nommer les col au lieu des cellules et plus de la boucle....
    Après 5 min ca va ce n'est pas très long et quand tu l'a fait une fois c'est bon.

    Avec ton code je pense que je vais essayer de mieux le comprendre pour le modifier et l'adapter sur la feuille 1. Tu penses que c'est possible?

    Dsl mais j'aimerais bien apprendre la VBA et c'est un bon exercice non?
    0
    1. cs_Le Pivert Messages postés 8437 Statut Contributeur 730
       
      Pour la feuille1, c'est à peu près pareil sauf que la VilleDepart ne bouge pas en A3 

      Sub bouclevillefeuille1()
Dim FL1 As Worksheet, NoCol As Integer
Dim NoLig As Long
Dim URL As String, TXT As String
Dim VilleDepart As String, VilleDestination As String
    Set FL1 = Worksheets("Feuil1")
    NoCol = 1 'lecture de la colonne A
    'Application.ScreenUpdating = False ' a mettre pour ne pas voir défiler
    On Error Resume Next
    For NoLig = 4 To Split(FL1.UsedRange.Address, "$")(4)
        VilleDepart = FL1.Cells(3, NoCol)  'on reste sur A3 
        VilleDestination = Cells(NoLig, NoCol)  'on boucle à partir de A4
        If VilleDepart = "" Then Exit Sub
With ActiveSheet
'construction du lien
URL = DIST & VilleDepart & "&destination=" & VilleDestination
With CreateObject("WinHTTP.WinHTTPRequest.5.1")
.Open "GET", URL, False
.Send
TXT = .ResponseText
End With
'extraction nbre km
Range("C" & NoLig) = Split(Split(TXT, "id=""distanciaRuta"">")(1), "</strong>")(0)
'on recupere durée trajet
'Range("D" & NoLig) = Split(Split(TXT, "id=""tiempo"">")(1), "</span></strong>")(0)
'on recupere lien Url transforme en lien hypertexte
'Range("E" & NoLig) = URL
'.Hyperlinks.Add .Range("E" & NoLig), URL
End With
 Next
    Set FL1 = Nothing
    'Application.ScreenUpdating = True 'retablir
End Sub


      Voilà,

      pour les cours vba il y en a plein sur le net en cherchant: Cours vba pour débutant

      un exemple:

      https://www.excel-pratique.com/fr/vba

      @+ Le Pivert
      0
      1. cs_Le Pivert Messages postés 8437 Statut Contributeur 730 > cs_Le Pivert Messages postés 8437 Statut Contributeur
         
        Pour compléter mettre toutes les distances sur la ligne3 correspondant aux villes (exécution longue aussi) 

        Sub bouclevilleligne3()
Dim FL1 As Worksheet, NoCol As Integer
Dim NoLig As Long, colonne As Integer
Dim URL As String, TXT As String
Dim VilleDepart As String, VilleDestination As String
    Set FL1 = Worksheets("Feuil1")
    NoCol = 1 'lecture de la colonne A
    colonne = 4 ' demarre colonne D
    'Application.ScreenUpdating = False ' a mettre pour ne pas voir défiler
    On Error Resume Next
    For NoLig = 4 To Split(FL1.UsedRange.Address, "$")(4)
        VilleDepart = FL1.Cells(3, NoCol)
        VilleDestination = Cells(NoLig, NoCol)
        If VilleDepart = "" Then Exit Sub
With ActiveSheet
'construction du lien
URL = DIST & VilleDepart & "&destination=" & VilleDestination
With CreateObject("WinHTTP.WinHTTPRequest.5.1")
.Open "GET", URL, False
.Send
TXT = .ResponseText
End With
'extraction nbre km
Cells(3, colonne) = Split(Split(TXT, "id=""distanciaRuta"">")(1), "</strong>")(0)
'on recupere durée trajet
'Range("D" & NoLig) = Split(Split(TXT, "id=""tiempo"">")(1), "</span></strong>")(0)
'on recupere lien Url transforme en lien hypertexte
'Range("E" & NoLig) = URL
'.Hyperlinks.Add .Range("E" & NoLig), URL
colonne = colonne + 1 'on passe à la colonne suivante
End With
 Next
    Set FL1 = Nothing
    'Application.ScreenUpdating = True 'retablir
End Sub


        j'ai mis des commentaires pour que tu comprennes la démarche.

        VBA, c'est de la logique!

        Amuse toi bien

        @+ Le Pivert
        0