Importer données web à partir d'une url concaténée

Le 01/04/2019 à 13:58
DRALLA a écrit :
Steelson a écrit :

Un tentative

Sub requete_post()

Dim obj As New DataObject
For i = 1 To 5
    With CreateObject("MSXML2.XMLHTTP")
        .Open "POST", Sheets("URL").Range("A1").Value, False
        .setRequestHeader "Content-Type", "application/x-www-form-urlencoded"
        .Send "__EVENTTARGET=ctl00$ContentPlaceHolderMain$PagerFooter&__EVENTARGUMENT=" & i & "&__VIEWSTATEGENERATOR=37C7F7E6"
        If .Status = 200 Then
            txt = "<table" & Split(Split(.responseText, "<table")(3), "</table>")(0) & "</table>"
            obj.SetText txt
            obj.PutInClipboard
            ActiveWorkbook.Sheets.Add After:=Worksheets(Worksheets.Count)
            ActiveSheet.Paste
            Selection.Delete
        End If
    End With
Next

End Sub

Bonjour Steelson,

Un grand merci c'est parfait

ReBonjour Steelson,

Désolé de vous solliciter encore.

Le code fonctionne sans soucis pour récupérer l'ensemble des pages ( clubs de plus de 41 joueurs)

(1 page= Liste de 40 Joueurs)

par contre l'import bug pour un club de moins de 40 j soit une page ?

Faut il placer une condition (else) dans la bouche IF... end If ?

merci de votre aide

Le 01/04/2019 à 14:59

Effectivement, j'ai été un peu vite et j'ai fixé le nombre de pages à 5 !

Change ceci en fonction du nombre de pages :

For i = 1 To 5

Je vais faire une recherche automatique sur le nombre de pages concernées ... à suivre, pas avant demain matin.

Le 01/04/2019 à 15:17
Steelson a écrit :

Effectivement, j'ai été un peu vite et j'ai fixé le nombre de pages à 5 !

Change ceci en fonction du nombre de pages :

For i = 1 To 5

Je vais faire une recherche automatique sur le nombre de pages concernées ... à suivre, pas avant demain matin.

Ok Steelson merci

Effectivement j'ai réussi à changer le nombre de pages pour des clubs à plus de 200 Jo ( 5 pages *40)

mais si le club recherché a de 1 à 40 jo soit une page la l'import bug.

J'ai reussi à bricoler un code ou je rentre le N° du club (1er question du post sur les lien concaténés)

pour ma recherche je ne connais pas à l'avance le nombre

de Joueurs donc le nombre de page.

j'ai donc fixer un nombre maxi de 10 pages qui couvre l'ensemble des recherches

pour resumer For 1 = To 10 fonctionne sauf For 1 to 1 !!

Le 01/04/2019 à 16:57

Bonjour à tous,

Pour compléter l'excellente solution de Steelson, voici une p'tite fonction pour récupérer le nb de pages :

Function NbPages(site As String) As Integer
Dim Html As New HTMLDocument, Elem As Object

    With CreateObject("WINHTTP.WinHTTPRequest.5.1")
        .Open "GET", site, False
        .send
        Html.body.innerHTML = .responseText
    End With
    On Error Resume Next
    For Each Elem In Html.getElementsByTagName("a")
        If IsNumeric(Elem.innerText) Then NbPages = Elem.innerText
    Next Elem
End Function

Du coup j'ai "panaché" les 2 méthodes dans cette proposition

Est-ce que ça fonctionne?

Pierre

16lire-tableau-ul-li-web-test.xlsm (28.86 Ko)
Le 01/04/2019 à 21:08
pierrep56 a écrit :

Bonjour à tous,

Pour compléter l'excellente solution de Steelson, voici une p'tite fonction pour récupérer le nb de pages :

Function NbPages(site As String) As Integer
Dim Html As New HTMLDocument, Elem As Object

    With CreateObject("WINHTTP.WinHTTPRequest.5.1")
        .Open "GET", site, False
        .send
        Html.body.innerHTML = .responseText
    End With
    On Error Resume Next
    For Each Elem In Html.getElementsByTagName("a")
        If IsNumeric(Elem.innerText) Then NbPages = Elem.innerText
    Next Elem
End Function

Du coup j'ai "panaché" les 2 méthodes dans cette proposition

Est-ce que ça fonctionne?

Pierre

Bonsoir Pierre

Impeccable.

Encore merci à vous et à Steelson.

Rapidité efficacité c'est top !

Le 02/04/2019 à 04:53

Bonjour Dralla & Pierre

Je propose une version qui rassemble toutes les données dans un seul onglet.

Elle devrait aussi pouvoir interroger plusieurs clubs.

J'ai repris bien sûr le code de Pierre qui permet d'obtenir le nombre de pages

11web-post-echecs-variante.xlsm (38.61 Ko)
Le 02/04/2019 à 09:32
Steelson a écrit :

Bonjour Dralla & Pierre

Je propose une version qui rassemble toutes les données dans un seul onglet.

Elle devrait aussi pouvoir interroger plusieurs clubs.

J'ai repris bien sûr le code de Pierre qui permet d'obtenir le nombre de pages

Bonjour Steelson

Merci de votre proposition. pour onglet unique

Apres test pas de soucis pour les clubs de plus de 40 membres par contre si moins de 40

pas d'affichage ?

exp http://www.echecs.asso.fr/ListeJoueurs.aspx?Action=JOUEURCLUBREF&ClubRef=320

erreur 1004 " Un tableau ne peut pas en chevaucher un autre"

Le 02/04/2019 à 12:49

Ok il faut donc faire comme Pierre, le premier tableau doit être lu via la méthode GET.

Je vais modifier.

Le 02/04/2019 à 13:18

Comme tu m'as donné une autre URL, j'ai aussi pu mettre au point le "multi-clubs"

Sub requete_post()
Dim obj As New DataObject
Dim ws As Worksheet

For Each ws In Worksheets

    ws.Select
    iRow = 4
    ws.Cells(iRow, 1).CurrentRegion.ClearContents
    ws.Cells(iRow, 1).Select

    nPages = NbPages(ws.Range("A1").Value)
    iTable = IIf(nPages > 1, 3, 2)

    For i = 1 To WorksheetFunction.Max(1, nPages)
        With CreateObject("MSXML2.XMLHTTP")
            If i = 1 Then
                .Open "GET", ws.Range("A1").Value, False
                .send
            Else
                .Open "POST", ws.Range("A1").Value, False
                .setRequestHeader "Content-Type", "application/x-www-form-urlencoded"
                .send "__EVENTTARGET=ctl00$ContentPlaceHolderMain$PagerFooter&__EVENTARGUMENT=" & i & "&__VIEWSTATEGENERATOR=37C7F7E6"
            End If
            If .Status = 200 Then
                txt = "<table" & Split(Split(.responseText, "<table")(iTable), "</table>")(0) & "</table>"
                obj.SetText txt
                obj.PutInClipboard
                ws.Paste
                Selection.Delete 'suppression des shapes
            End If
        End With
        If i > 1 Then ws.Rows(iRow).Delete 'suppression en-tête inutile
        iRow = ws.Cells(Rows.Count, 1).End(xlUp).Row + 1
        ws.Cells(iRow, 1).Select
    Next

    ws.ListObjects.Add(xlSrcRange, Range("$A$4").CurrentRegion, , xlYes).Name = "T_" & ws.Name
    Range("T_" & ws.Name & "[#All]").Select
    ws.ListObjects(1).TableStyle = "TableStyleMedium2"

Next

End Sub

Function NbPages(site As String) As Integer
' Pierre56
Dim Html As New HTMLDocument, Elem As Object
    With CreateObject("WINHTTP.WinHTTPRequest.5.1")
        .Open "GET", site, False
        .send
        Html.body.innerHTML = .responseText
    End With
    On Error Resume Next
    For Each Elem In Html.getElementsByTagName("a")
        If IsNumeric(Elem.innerText) Then NbPages = Elem.innerText
    Next Elem
End Function
19web-post-echecs-variante.xlsm (42.58 Ko)
Le 02/04/2019 à 15:57
Steelson a écrit :

Comme tu m'as donné une autre URL, j'ai aussi pu mettre au point le "multi-clubs"

Sub requete_post()
Dim obj As New DataObject
Dim ws As Worksheet

For Each ws In Worksheets

    ws.Select
    iRow = 4
    ws.Cells(iRow, 1).CurrentRegion.ClearContents
    ws.Cells(iRow, 1).Select

    nPages = NbPages(ws.Range("A1").Value)
    iTable = IIf(nPages > 1, 3, 2)

    For i = 1 To WorksheetFunction.Max(1, nPages)
        With CreateObject("MSXML2.XMLHTTP")
            If i = 1 Then
                .Open "GET", ws.Range("A1").Value, False
                .send
            Else
                .Open "POST", ws.Range("A1").Value, False
                .setRequestHeader "Content-Type", "application/x-www-form-urlencoded"
                .send "__EVENTTARGET=ctl00$ContentPlaceHolderMain$PagerFooter&__EVENTARGUMENT=" & i & "&__VIEWSTATEGENERATOR=37C7F7E6"
            End If
            If .Status = 200 Then
                txt = "<table" & Split(Split(.responseText, "<table")(iTable), "</table>")(0) & "</table>"
                obj.SetText txt
                obj.PutInClipboard
                ws.Paste
                Selection.Delete 'suppression des shapes
            End If
        End With
        If i > 1 Then ws.Rows(iRow).Delete 'suppression en-tête inutile
        iRow = ws.Cells(Rows.Count, 1).End(xlUp).Row + 1
        ws.Cells(iRow, 1).Select
    Next

    ws.ListObjects.Add(xlSrcRange, Range("$A$4").CurrentRegion, , xlYes).Name = "T_" & ws.Name
    Range("T_" & ws.Name & "[#All]").Select
    ws.ListObjects(1).TableStyle = "TableStyleMedium2"

Next

End Sub

Function NbPages(site As String) As Integer
' Pierre56
Dim Html As New HTMLDocument, Elem As Object
    With CreateObject("WINHTTP.WinHTTPRequest.5.1")
        .Open "GET", site, False
        .send
        Html.body.innerHTML = .responseText
    End With
    On Error Resume Next
    For Each Elem In Html.getElementsByTagName("a")
        If IsNumeric(Elem.innerText) Then NbPages = Elem.innerText
    Next Elem
End Function

Merci Steelson cette fois cela fonctionne quel que soit le nombre de joueurs dans le club.

Merci à toi et Pierre pour l'aide précieuse.

Le 08/04/2019 à 00:00
DRALLA a écrit :
Steelson a écrit :

Comme tu m'as donné une autre URL, j'ai aussi pu mettre au point le "multi-clubs"

Sub requete_post()
Dim obj As New DataObject
Dim ws As Worksheet

For Each ws In Worksheets

    ws.Select
    iRow = 4
    ws.Cells(iRow, 1).CurrentRegion.ClearContents
    ws.Cells(iRow, 1).Select

    nPages = NbPages(ws.Range("A1").Value)
    iTable = IIf(nPages > 1, 3, 2)

    For i = 1 To WorksheetFunction.Max(1, nPages)
        With CreateObject("MSXML2.XMLHTTP")
            If i = 1 Then
                .Open "GET", ws.Range("A1").Value, False
                .send
            Else
                .Open "POST", ws.Range("A1").Value, False
                .setRequestHeader "Content-Type", "application/x-www-form-urlencoded"
                .send "__EVENTTARGET=ctl00$ContentPlaceHolderMain$PagerFooter&__EVENTARGUMENT=" & i & "&__VIEWSTATEGENERATOR=37C7F7E6"
            End If
            If .Status = 200 Then
                txt = "<table" & Split(Split(.responseText, "<table")(iTable), "</table>")(0) & "</table>"
                obj.SetText txt
                obj.PutInClipboard
                ws.Paste
                Selection.Delete 'suppression des shapes
            End If
        End With
        If i > 1 Then ws.Rows(iRow).Delete 'suppression en-tête inutile
        iRow = ws.Cells(Rows.Count, 1).End(xlUp).Row + 1
        ws.Cells(iRow, 1).Select
    Next

    ws.ListObjects.Add(xlSrcRange, Range("$A$4").CurrentRegion, , xlYes).Name = "T_" & ws.Name
    Range("T_" & ws.Name & "[#All]").Select
    ws.ListObjects(1).TableStyle = "TableStyleMedium2"

Next

End Sub

Function NbPages(site As String) As Integer
' Pierre56
Dim Html As New HTMLDocument, Elem As Object
    With CreateObject("WINHTTP.WinHTTPRequest.5.1")
        .Open "GET", site, False
        .send
        Html.body.innerHTML = .responseText
    End With
    On Error Resume Next
    For Each Elem In Html.getElementsByTagName("a")
        If IsNumeric(Elem.innerText) Then NbPages = Elem.innerText
    Next Elem
End Function

Merci Steelson cette fois cela fonctionne quel que soit le nombre de joueurs dans le club.

Merci à toi et Pierre pour l'aide précieuse.

Bonjour Steelson.

une question concernant les liens hypertext : ils sont perdus lors de l'importation.

( ils s'effacent lors du chargement des pages)

Existe t il un moyen de les conserver ?

si oui je vous remercie .

Cordialement.

Le 08/04/2019 à 08:45
DRALLA a écrit :

Bonjour Steelson.

une question concernant les liens hypertext : ils sont perdus lors de l'importation.

( ils s'effacent lors du chargement des pages)

Existe t il un moyen de les conserver ?

Ces liens ? http://www.echecs.asso.fr/FicheJoueur.aspx?Id=761395

ok je vais regarder , je ne savais pas que c'était utile !

Le 08/04/2019 à 10:22
Steelson a écrit :
DRALLA a écrit :

Bonjour Steelson.

une question concernant les liens hypertext : ils sont perdus lors de l'importation.

( ils s'effacent lors du chargement des pages)

Existe t il un moyen de les conserver ?

Ces liens ? http://www.echecs.asso.fr/FicheJoueur.aspx?Id=761395

ok je vais regarder , je ne savais pas que c'était utile !

Bonjour Steelson.

Oui ces liens ( fiche Joueur) .

Mais aussi plus généralement d'autres liens dans d'autre requetés ?

pour ne pas qu'ils se perdent lors de l'importation

Le 08/04/2019 à 11:58

Le lien est représenté par le petit carré bleu.

15web-post-echecs-v3.xlsm (27.77 Ko)
Le 08/04/2019 à 14:07
Steelson a écrit :

Le lien est représenté par le petit carré bleu.

Merci Steelson pour la proposition, malheureusement le code bug

Application.CommandBars("Format Object").Visible = False

Grace à votre aide du début de post j'ai réussi à concaténer les liens pour pouvoir importer en fonction du numero du club

il m''est donc pas nécessaire de faire une recherche en multiclub ( 2 dans l'exemple)

1 seul suffirait.

mais pour pouvoir importer de 1 à 5 pages web (selon la taille du club) sous forme de tableau

(comme vos propositions plus haut dans le post le permet)

mais

en intégrant les liens ( petits carrés bleus"

Le 08/04/2019 à 17:38
DRALLA a écrit :
Steelson a écrit :

Le lien est représenté par le petit carré bleu.

Merci Steelson pour la proposition, malheureusement le code bug

Je n'ai aucun bug.

Le bug se produit-il dans le fichier que j'ai posté ou bien après duplication de la macro dans un autre fichier ?

Le 08/04/2019 à 21:59
Steelson a écrit :
DRALLA a écrit :
Steelson a écrit :

Le lien est représenté par le petit carré bleu.

Merci Steelson pour la proposition, malheureusement le code bug

Je n'ai aucun bug.

Le bug se produit-il dans le fichier que j'ai posté ou bien après duplication de la macro dans un autre fichier ?

Dans le fichier posté

à l'ouverture sans l'enregistrer

Le 08/04/2019 à 23:37

Curieux !! car aucune macro n'est lancée en ouverture ...

Pas grave, supprime cette ligne de la macro ...

29web-post-echecs-v3-1.xlsm (27.77 Ko)
Le 10/04/2019 à 23:09
Steelson a écrit :

Curieux !! car aucune macro n'est lancée en ouverture ...

Pas grave, supprime cette ligne de la macro ...

Bonjour Steelson.

suite à votre conseil, j'ai supprimé la ligne de code

maintenant cela fonctionne très bien

Encore merci

Cordialement

Le 16/04/2019 à 17:52
Steelson a écrit :

Curieux !! car aucune macro n'est lancée en ouverture ...

Pas grave, supprime cette ligne de la macro ...

bonjour Steelson, Bonjour Pierre

Avec les différents codes que vous m'avez proposés, j'essaye d'en mixer un pour pouvoir :

Importer la liste des joueurs d'un club quelconque en conservant les liens hypertexte de la rubrique infos.

Le code qui permet de conserver les "shapes" étant imbriqué dans le code d'importation , je n'arrive pas à le

récupérer pour pouvoir l'integrer ailleurs.

Merci de votre aide

9essai.xlsm (42.65 Ko)
Rechercher des sujets similaires à "importer donnees web partir url concatenee"