Optimisation de code (connexions multiple à Internet)

Version imprimable

Voir 40 message(s) de cette discussion en une page

26/01/2016, 13h03
patricktoulon

re

:mouarf:
bon je file au boulot se soir je m'ocupe de son autre post ca s'avere plus complexe qu 'il n'y parrait
26/01/2016, 14h27
Hexa82

Ce qui ne sera pas pour te déplaire car tu m'as dit récemment que tu appréciais la complexité... ^^

Marc, si j'ai bien saisi ce que tu expliques, il faudrait avoir le lien final afin que la requête aboutisse.

Alors... Y a t-il un moyen d'avoir le lien final ?

Citation:

Envoyé par Hexa82

Pour info, je n'ai rien modifié au fichier fourni sur le fofo vert par G...in.
Tu m'avais mis le doute et je viens de télécharger à nouveau le doc excel pour vérifier...

Il y a pourtant de malheureuses modifications vis à vis de mon code original du 28/3/2015 20h !
Quelqu'un l'a donc modifié sans comprendre ce qu'il faisait …

Citation:

Envoyé par patricktoulon

marc je ne suis pas d'accords ,meme avec 31 lignes a traiter le gain de temps est consquent

Mouais, je gagne à peine dix secondes de mon côté …
Le code original sur le forum verdâtre (sans mes p'tites abeilles) stockait tout dans une variable tableau
afin de n'afficher le résultat qu'en fin de procédure afin de gagner un peu de temps mais qui pour le pékin moyen apparaît long, certainement la raison des modifications du code initial de cette discussion …

P'tite modif ne laissant apparaître que les montants :
Code:

1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 Sub Requetes() Dim oWs As Object, R&, SC$, X% With Feuil1 R = .Cells(1).CurrentRegion.Rows.Count .[B2].Resize(R - 1).ClearContents SC = ThisWorkbook.Path & "\Cote.vbs" X = FreeFile Open SC For Output As #X Print #X, "With CreateObject(""MSXML2.XMLHTTP"")" & vbCrLf & _ ".Open ""GET"", WScript.Arguments(0), False" & vbCrLf & _ ".setRequestHeader ""DNT"", ""1""" & vbCrLf & _ "On Error Resume Next" & vbCrLf & _ ".send" & vbCrLf & _ "If .status = 200 Then V = Split(Split(.responseText, ""cotation"""">"")(1))(0) _" & vbCrLf & _ " Else V = .status & "" : "" & .statusText" & vbCrLf & _ "End With" & vbCrLf & _ "GetObject(,""Excel.Application"").Workbooks(""" & ThisWorkbook.Name & """).Worksheets(""" & .Name & """).Cells(WScript.Arguments(1), 2).Value = V" Close #X SC = """" & SC & """ " Set oWs = CreateObject("WScript.Shell") For R = 2 To R: oWs.Run SC & .Cells(R, 1).Hyperlinks(1).Address & " " & R: Next Set oWs = Nothing End With End Sub

26/01/2016, 15h50
Marc-L

Citation:

Envoyé par Hexa82

Alors... Y a t-il un moyen d'avoir le lien final ?

~~C'est juste visuel ! Après avoir cliqué sur le lien, ne vois-tu pas l'adresse n'étant plus celle du lien ?~~

Autant pour moi, c'est juste pour celle de l'opcvm …
~~En fait il y aurait des pages codées différemment des autres~~, un classique sur ce genre de site !
~~Je verrais plus tard, Patrick confirmera … Cette discussion n'est pas résolue, tu peux la rouvrir !~~
26/01/2016, 16h07
Hexa82

Merci pour le code V2.

Ah oui, ils ont du modifier les liens des trackers récemment.

J'ai vu où modifier la ligne prise en compte et la colonne dans laquelle on souhaite qu'apparaissent les résultats.

En revanche, pourrais-tu m'indiquer où l'on définit la colonne des liens ?
26/01/2016, 16h13
Marc-L

Dans la ligne de code n°14 …

Mais ne te précipite pas, le code risque de changer à cause de certaines pages, voir mon post précédent édité après le tien …
26/01/2016, 16h14
Hexa82

Merci :D

Au secours, je vais devenir folle !

J'ai modifié le code afin que les liens soient dans la colonne P et le cours des actions dans la colonne T.

Les cours ne s'affichent que s'il y a du texte (j'ai donc écrit "blablabla" dans 5 cellules) dans la colonne A. Dès que je retire le texte dans la colonne A, j'ai une erreur (Erreur définie par l'application ou par l'objet).

Quelle est donc cet étrange souci ?

Merci d'avance Marc.

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
Sub Requetes()
    Dim CODE As String, R&, SC$, X%, oWs As Object
  With Feuil1
    R = .Cells(1).CurrentRegion.Rows.Count
    .[B2].Resize(R - 1).ClearContents
    CODE = "On Error Resume Next" & vbCrLf & _
           "With CreateObject(""MSXML2.XMLHTTP"")" & vbCrLf & _
           ".Open ""GET"", WScript.Arguments(0), False" & vbCrLf & _
           ".send" & vbCrLf & _
           "V = Split(Split(.responseText, ""cotation"""">"")(1))(0)" & vbCrLf & _
           "End With" & vbCrLf & _
           "If V = """" Then V = ""erreur""" & vbCrLf & _
           "GetObject(,""Excel.Application"").Workbooks(""" & ThisWorkbook.Name & _
           """).Worksheets(""" & .Name & """).Cells(WScript.Arguments(1), 20).Value = V"
    SC = ThisWorkbook.Path & "\Cote.vbs"
     X = FreeFile
    Open SC For Output As #X
    Print #X, CODE
    Close #X
                      SC = """" & SC & """ "
                 Set oWs = CreateObject("WScript.Shell")
    For R = 2 To R:  oWs.Run SC & .Cells(R, 16).Value & " " & R:  Next
                 Set oWs = Nothing
  End With
End Sub

26/01/2016, 20h24
Marc-L

En fait c'est tout bête ! En retournant le code d'erreur de la requête, j'ai obtenu le fameux 404 d'une page inexistante.
En effet, la valeur de certaines cellules de la colonne des liens est tronquée par rapport au lien hypertexte correspondant !

Voir le correctif dans le post #23 récupérant bien le lien hypertexte au lieu de la valeur de la cellule …
Ligne n°21 : cellule du lien … Ligne n°17 : cellule de la cotation …
A la place du n° de la colonne, possible d'indiquer sa lettre entre guillemets …

Et au passage l'avant dernière ligne dans la colonne des liens est en double avec la deuxième !
26/01/2016, 21h28
Hexa82

Merci Marc, je prends et vais tester.

Bonne remarque concernant le doublon, mais c'est normal.
Il s'agit d'un ETF que j'ai acheté à 2 moments différents (et donc à des PRU différents) dans 2 enveloppes répondant à une imposition différente (Compte titres et PEA).

J'ai essayé la nouvelle mouture mais je n'ai pas plus de résultats.
Je l'ai lancé avant de le modifier et j'ai une erreur ligne 21 (l'indice n'appartient pas à la sélection) mais les cotations s'affichent quand même.
En revanche, lorsque j'essaie de modifier ne serait-ce que la cellule d'affichage des cotation, l'erreur est toujours présente mais je n'ai plus d'affichage du tout :weird:

J'ai quand même tenté avec les lettres de colonne comme tu l'avais suggéré :
Concernant .Cells(WScript.Arguments(1), "; T; ") L'éditeur rajoute automatiquement des ; et des espaces de part et d'autre que je ne peux enlever et me donne une erreur de syntaxe lors de l'exécution... Là je n'ai rien compris ^^

Qu'est-ce qui se passe docteur Marc ???
26/01/2016, 23h07
Marc-L

Oui mais au sein d'une chaîne de caractères, donc encadrée par des guillemets,

les guillemets doivent être doublés : .Cells(WScript.Arguments(1), ""T"") …
Sinon utiliser le n° de la colonne !

Si c'est ma ligne n°21, quelle est la valeur de R lors de l'erreur ?
T'as dû oublier de modifier les lignes n°4 & 5 :
R = .Cells(16).CurrentRegion.Rows.Count …
.[T2].Resize(R - 1).ClearContents

Bonjour Marc

Effectivement, j'avais oublié de modifier le haut :oops: MERCI

Le code fonctionne très bien dans un classeur vierge mais génère une erreur dans mon classeur cible.
Erreur à la ligne 5 (Erreur définie par l'application ou l'objet)

Aurais-tu une idée ?

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
Sub Requetes()
    Dim oWs As Object, R&, SC$, X%
  With Feuil1
     R = .Cells(16).CurrentRegion.Rows.Count
    .[T2].Resize(R - 1).ClearContents
    SC = ThisWorkbook.Path & "\Cote.vbs"
     X = FreeFile
    Open SC For Output As #X
    Print #X, "With CreateObject(""MSXML2.XMLHTTP"")" & vbCrLf & _
          ".Open ""GET"", WScript.Arguments(0), False" & vbCrLf & _
          ".setRequestHeader ""DNT"", ""1""" & vbCrLf & _
          "On Error Resume Next" & vbCrLf & _
          ".send" & vbCrLf & _
          "If .status = 200 Then V = Split(Split(.responseText, ""cotation"""">"")(1))(0) _" & vbCrLf & _
          "                 Else V = .status & "" : "" & .statusText" & vbCrLf & _
          "End With" & vbCrLf & _
          "GetObject(,""Excel.Application"").Workbooks(""" & ThisWorkbook.Name & """).Worksheets(""" & .Name & """).Cells(WScript.Arguments(1), ""T"").Value = V"
    Close #X
                      SC = """" & SC & """ "
                 Set oWs = CreateObject("WScript.Shell")
    For R = 4 To R:  oWs.Run SC & .Cells(R, 16).Hyperlinks(1).Address & " " & R:  Next
                 Set oWs = Nothing
  End With
End Sub

27/01/2016, 10h35
Marc-L

L'erreur se déclenche si R vaut 1 (?) c'est à dire il n'y aurait pas de lien dans la colonne 16 !

Et il ne doit pas y avoir de ligne vide entre les liens et le premier lien doit être en ligne n°2 …

Et évidemment la feuille de calculs ne doit pas être protégée, sinon les cellules doivent être au moins déverrouillées !
27/01/2016, 11h01
Hexa82

Il y a 31 liens.
La feuille n'est pas protégée !

Le premier lien est en ligne 4, c'est pour ça que j'ai modifié le code en conséquence ici (mais il y a peut être un autre endroit à modifier ?) :

Code:

For R = 4 To R: oWs.Run SC & .Cells(R, 16).Hyperlinks(1).Address & " " & R: Next

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
Sub Requetes()
    Dim oWs As Object, R&, SC$, X%
  With Feuil1
     'R = .Cells(4, 16).CurrentRegion.Rows.Count
    R = .Cells(Rows.Count, 16).End(xlUp).Row
    .[T4].Resize(R - [T4].Row + 1).ClearContents
    SC = ThisWorkbook.Path & "\Cote.vbs"
     X = FreeFile
    Open SC For Output As #X
    Print #X, "With CreateObject(""MSXML2.XMLHTTP"")" & vbCrLf & _
          ".Open ""GET"", WScript.Arguments(0), False" & vbCrLf & _
          ".setRequestHeader ""DNT"", ""1""" & vbCrLf & _
          "On Error Resume Next" & vbCrLf & _
          ".send" & vbCrLf & _
          "If .status = 200 Then V = Split(Split(.responseText, ""cotation"""">"")(1))(0) _" & vbCrLf & _
          "                 Else V = .status & "" : "" & .statusText" & vbCrLf & _
          "End With" & vbCrLf & _
          "GetObject(,""Excel.Application"").Workbooks(""" & ThisWorkbook.Name & """).Worksheets(""" & .Name & """).Cells(WScript.Arguments(1), ""T"").Value = V"
    Close #X
                      SC = """" & SC & """ "
                 Set oWs = CreateObject("WScript.Shell")
    For R = 4 To R:  oWs.Run SC & .Cells(R, 16).Hyperlinks(1).Address & " " & R:  Next
                 Set oWs = Nothing
  End With
End Sub

27/01/2016, 13h04
Hexa82

Salut Patrick

Ça faisait longtemps qu'on ne t'avait pas vu sur ce post :P

Il y a du mieux avec ton code, j'ai 9 cotations qui apparaissent sur les 31.
J'ai le message d'erreur : L'indice n'appartient pas à la sélection
27/01/2016, 14h22
Marc-L

Sans connaître la ligne déclenchant l'erreur …
27/01/2016, 14h29
Hexa82

Désolée, je faisais d'autres essais...
Car en fait le nombre de cotations affichées est aléatoire...
Je viens d'en avoir 18 (sur 31) à l'instant !

La ligne qui pose un souci est :

Code:

For R = 4 To R: oWs.Run SC & .Cells(R, 16).Hyperlinks(1).Address & " " & R: Next

Erreur d'exécution 9 : L'indice n'appartient pas à la sélection.
27/01/2016, 15h01
patricktoulon

re

ca y est je sais pourquoi" l'indice n'apartient pas ......"

en fait marc te la fait avec l'yperlin de la cellule a l'inverse de moi qui l'avais fait au depart avec la value

donc j'ai repris avec value et j'ai bien le message d'erreur conclusion tes 31 ne sont pas tous des yper lien

clique 2 fois sur tous pour les transformer en lien
sinon il faudra reprendre le principe avec la valeur

il faut qu'il soient tous bleu :mrgreen:
27/01/2016, 15h06
patricktoulon

1 pièce(s) jointe(s)

re

la preuve en image
Pièce jointe 199226

Voir 40 message(s) de cette discussion en une page