Extraction de données de pages web

Version imprimable

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

ta methode if ubound(blabla) ne marche par pour tout ou alors il faut répeter la ligne
voila j'ai mes 5 colonnes dans le sheets et dans le html
bon cerede2000 tu voulais de DOMable
tiens
lance la sub DemoReq1

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
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
Const entete = "Nom" & vbTab & "lieu" & vbTab & "date" & vbTab & "soutien" & vbTab & "oseille"
Sub DemoReq1()
    Dim SPQ, lieu, SP, dt, Ps
    With CreateObject("MSXML2.XMLHttp")
        Do
            P% = P% + 1
            .Open "GET", "http://www.kisskissbankbank.com/fr/projects/bigdream/contributors?page=" & P, False
            .setRequestHeader "Accept", "*/*;q=0.5, text/javascript, application/javascript, application/ecmascript, application/x-ecmascript"
            .setRequestHeader "DNT", "1"
            On Error Resume Next
            .send
            On Error GoTo 0
            If .Status = 200 Then
                SPQ = Split(.responsetext, "class=\""username\"">")
                For r% = 1 To UBound(SPQ)
                    lieu = "": fric = ""
                    T$ = T$ & Split(SPQ(r), "<")(0)
                    If InStr(SPQ(r), "class=\'amount\'>") > 0 Then fric = Split(Split(SPQ(r), "class=\'amount\'>")(1), "<")(0)
                    If InStr(SPQ(r), "class=\'location\'>") > 0 Then lieu = Split(Split(SPQ(r), "class=\'location\'>")(1), "<")(0)
                    T = T & vbTab & lieu
                    dt = Split(Split(SPQ(r), "class=\'date-reward\'>\n")(1), "\n")(0)
                    If InStr(SPQ(r), "class=\""count\"">") > 0 Then Ps = Split(Split(SPQ(r), "class=\""count\"">")(1), "<")(0) & " Projets soutenus"
                    T = T & vbTab & dt & vbTab & Ps
                    T = T & vbTab & fric
                    T = T & vbLf
                Next
                If UBound(Split(SPQ(r - 1), ".remove()")) Then Exit Do
            Else
                Exit Do
            End If
        Loop
    End With
    If T > "" Then
        Application.ScreenUpdating = False
        SPQ = Split(entete & vbLf & T, vbLf)
        With Cells(1).Resize(UBound(SPQ))
            .CurrentRegion.Clear
            .Value = Application.Transpose(SPQ)
            .TextToColumns
            .Columns(1).Replace "&#x27;", "'"
            .Columns(1).AutoFit
        End With
        Application.ScreenUpdating = True
    End If
   vision_dans_IE T
End Sub
Sub vision_dans_IE(texte)
    entet = "<TR><TH>" & Replace(entete, vbTab, "</TH><TH>") & "</TH></TR>" & vbLf
    'Debug.Print entet
    texte = "<TR><TD>" & Replace(texte, vbTab, "</TD><TD>")
    texte = Replace(texte, vbLf, "</TD></TR>" & vbLf & "<TR><TD>")
    texte = texte & "</TABLE>"
    Debug.Print Split(texte, vbLf)(0)
    'juste un peu de style
    Lstyle = "<style> TD{border:1px solid blue;}Table{border: 2px double red;border-collapse: collapse;}TH {background-color: yellow;border:1px dashed green;color:blue;} </style>"
       With CreateObject("internetexplorer.application")
        .Visible = True
        .navigate "about:blank"
        .document.write Lstyle & vbLf & "<TABLE>" & entet & texte
    End With
End Sub

dom tant que tu veux dans ie ;)

02/04/2016, 14h41
cerede2000

Great :)
Thanks !!!!!!

Citation:

Envoyé par patricktoulon

ta methode if ubound(blabla) ne marche par pour tout ou alors il faut répeter la ligne
voila j'ai mes 5 colonnes dans le sheets

Aucun souci de mon côté avec DemoReq1 & 2 …
Ah maintenant c'est cinq colonnes : pour chaque colonne où l'information peut ne pas exister,
effectivement il faut vérifier si elle est présente :

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
26
27
28
29
30
31
32
33
34
35
36
37
38
39
Sub DemoReq3()
                Dim VA(1 To 99999, 1 To 5), L&, P%, R%, SP, SPQ
                Cells(2).CurrentRegion.Clear
    With CreateObject("MSXML2.XMLHttp")
        Do
             P% = P% + 1
            .Open "GET", "http://www.kisskissbankbank.com/fr/projects/les-succulentes/contributors?page=" & P, False
            .setRequestHeader "Accept", "*/*;q=0.5, text/javascript, application/javascript, application/ecmascript, application/x-ecmascript"
            .setRequestHeader "DNT", "1"
             On Error Resume Next
            .send
             On Error GoTo 0
            If .Status = 200 Then
                   SPQ = Split(.responseText, "class=\""username\"">")
                 For R = 1 To UBound(SPQ)
                           L = L + 1
                    VA(L, 1) = Split(SPQ(R), "<")(0)
                    VA(L, 3) = CDate(Replace(Split(Split(SPQ(R), "class=\'date-reward\'>")(1), "<")(0), "\n", ""))
                          SP = Split(SPQ(R), "class=\'location\'>")
                    If UBound(SP) Then VA(L, 2) = Split(SP(1), "<")(0)
                          SP = Split(SPQ(R), "class=\""count\"">")
                    If UBound(SP) Then VA(L, 4) = Split(SP(1), "<")(0)
                          SP = Split(SPQ(R), "class=\'amount\'>")
                    If UBound(SP) Then VA(L, 5) = Split(SP(1))(0)
                 Next
                    If UBound(Split(SPQ(R - 1), ".remove()")) Then Exit Do
            Else
                Exit Do
            End If
        Loop
    End With
    If L Then
        With [B1:F1].Resize(L)
            .Value = VA
            .Columns(1).Replace "&#x27;", "'"
            .Columns("A:B").AutoFit
        End With
    End If
End Sub

______________________________________________________________________________________________________

La rigueur vient toujours à bout de l’obstacle. (Leonard de Vinci)

02/04/2016, 16h12
patricktoulon

re
@marc
oui c'est bien ce que je disais il faut répéter la ligne de split et du if ubound()

je voulais pas faire comme ca je suis sur que par des replaces bien placé au bon moment on peut contrecarrer le fait qu'il y a des manquants sans un seul if
c'est ca la beauté de l'exercice c'est plus marrant non?
02/04/2016, 16h37
Marc-L

Oui si tu veux, pour le sport !

Mais ne pas oublier lors d'une réponse à un demandeur (et vu son affirmation « mon code marche » alors que non !),
faut-il encore essayer de rester simple et efficace pour donner une p'tite chance au code d'être compris …

Là il part d'IE et on lui sort des requêtes, ce n'est pas gagné ! :ptdr: En tout cas maintenant il a le choix …
02/04/2016, 16h40
cerede2000

Et depuis le temps que l'on ne l'as pas vu sur le topic si ça se trouve il à pris peur :mouarf::mouarf::mouarf:
En tout cas ça m'auras appris IE et les requêtes en même temps c'est coooool :ptdr:

re
pour tout les deux
finalement c'était beaucoup plus simple que je croyais
en effet plus haut dans mes post je disais c'est presque du html c'est pas peut dire
je me suis embeté a charcher les chaine repetitive alors qu'il fallait seulement regarder les pseudobalise

regardez dans le debug le code html comme il est beau sans un if ou split

pour le netoyé de toute propriété qui nous interesse plus
on pourrais l'injecter dans un htmlfile
et dans une boucle on fait elem.innerhtml=elem.innertext

je vous laisse regarder avant de mettre ca au point
Code:

1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 Sub test2() Do Dim Req, url As String, memodoc url = "http://www.kisskissbankbank.com/fr/projects/bigdream/contributors?page=" & i Set Req = CreateObject("microsoft.xmlhttp") Set memodoc = CreateObject("htmlfile") With Req .Open "get", url, False .setRequestHeader "Accept", "*/*;q=0.5, text/javascript, application/javascript, application/ecmascript, application/x-ecmascript" .send texte = .responsetext texte = Replace(Replace(Replace(Replace(texte, "\'", ""), "\n", ""), "<\/tr><tr", "</tr>" & vbLf & "<tr>"), "<\/a><\/td>", "</a></td>") texte = Replace(Replace(Replace(texte, "\" & Chr(34), Chr(34)), "/></a>", "</img></a>"), "<\/", "</") texte = Replace(texte, "</span>", "") Debug.Print texte End With i = i + 1 Loop Until InStr(texte, "remove") > 0 End Sub
c'est magique !!!

02/04/2016, 16h57
cerede2000

Hum pas mal !!!!!!
Juste un petit souci :aie:

Ca pas bon....

Code:

<tr> class=user-thumb>

Code:

texte = Replace(Replace(Replace(Replace(texte, "\'", ""), "\n", ""), "<\/tr><tr", "</tr>" & vbLf & "<tr>"), "<\/a><\/td>", "</a></td>")

=>

Code:

texte = Replace(Replace(Replace(Replace(texte, "\'", ""), "\n", ""), "<\/tr><tr", "</tr>" & vbLf & "<tr"), "<\/a><\/td>", "</a></td>")

et oui il y avais encore deux ou 3 petites erreur mais c'est corrigé j'ai même ma colonne soutien même pour ce qu'il n'en ont pas en chuintant le span toujours sans split ou boucle

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
Sub test2()
    Do
        Dim Req, url As String, memodoc
        url = "http://www.kisskissbankbank.com/fr/projects/bigdream/contributors?page=" & i
        Set Req = CreateObject("microsoft.xmlhttp")
        Set memodoc = CreateObject("htmlfile")
        With Req
            .Open "get", url, False
            .setRequestHeader "Accept", "*/*;q=0.5, text/javascript, application/javascript, application/ecmascript, application/x-ecmascript"
            .send
            texte = .responsetext
            texte = Replace(Replace(Replace(Replace(texte, "\'", ""), "\n", ""), "<\/tr><tr", "</tr>" & vbLf & "<tr>"), "<\/a><\/td>", "</a></td>")
            texte = Replace(Replace(Replace(texte, "\" & Chr(34), Chr(34)), "/></a>", "</img></a>"), "<\/", "</")
            texte = Replace(Replace(Replace(texte, "</span>", ""), "<span class=""count"">", ""), "<tr> class", "<tr class")
            Debug.Print texte
        End With
        i = i + 1
    Loop Until InStr(texte, "remove") > 0
 
End Sub

Par contre j'ai la très nette impression que les replace sont plus long que les split de split de @Marc-L :weird:

En tous ca c'est top :) une fois mis dans un htmlfile :mouarf:
Code:

1 2 3 4 5 6 7 For Each Table In HTMLdoc.getElementsByTagName("table") For Each Row In Table.Rows For Each cell In Row.Cells Debug.Print cell.innerHTML Next Next Next
Et a quel moment tu vire les bout de JQuery qui traînaient ? Je ne vois pas :)

02/04/2016, 17h15
patricktoulon

re

re
plus long
oh.. je sais pas mais c'est la beauté de l'exercice qui m'amuse :) en douceur sans condition ca ne peut pas buger sur un index de split ou autre

il est vrai que pourtant je pense être le seul a avoir présenter un jour un code du genre split(split(split(split(split(truc,,)(1) ca faisait bien rie marc a l'époque mais ca fonctionnait :mouarf:
reste a nettoyer ;)

Citation:

Et a quel moment tu vire les bout de JQuery qui traînaient ? Je ne vois pas :)

je cherche le moyen sans split

je pense que je vais le faire dans la boucle du htmlfile :je prend que les TR forcement les lignes sautent
02/04/2016, 17h23
cerede2000

Moi je part plutôt sur les TD direct puis un if ou un select case sur className :mrgreen:
02/04/2016, 17h38
patricktoulon

re

et non par pour le moment
je viens de réussir a séparer les date dans un td elle était dans un div avant a l'intérieur d'un a qui était a l'intérieur d'un TD

laisse moi du temps

Non mais moi ce que je ferais :mouarf:
Like this :

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
26
    Dim divs As Object
    For Each td In HTMLdoc.getElementsByTagName("TD")
        If td.className = "name" Then
            If Name <> vbNullString Then Debug.Print Name & " " & Location & " " & dt & " " & contributed & " " & amount
 
            Name = td.getElementsByTagName("A")(0).innerText
            Location = ""
            contributed = ""
            amount = ""
 
            Set divs = td.getElementsByTagName("DIV")
            If divs.Length = 2 Then
                Location = divs(0).innerText
                dt = divs(1).innerText
            Else
                dt = divs(0).innerText
            End If
 
        End If
        If td.className = "contributed" Then
            contributed = td.innerText
        End If
        If td.className = "amount" Then
            amount = td.innerText
        End If
    Next

Grrrrrr si seulement la classe htmlfile avait la méthode getelementsbyclassname..... Ca serait encore plus simple !

02/04/2016, 20h26
Marc-L

Citation:

Envoyé par patricktoulon

je pense être le seul a avoir présenter un jour un code du genre split(split(split(split(split(truc,,)(1)
ca faisait bien rie marc a l'époque mais ca fonctionnait

J'ai pu m'apercevoir de la vélocité de Split comparativement aux fonctions texte VBA classiques comme Instr, Mid, …

Et combiné avec une variable tableau, c'est assez efficace ! Tout dépend aussi de la source …

Sinon dans le genre je ne vois pas mieux que les expressions rationnelles (ou régulières RegEx / RegExp).
02/04/2016, 20h44
cerede2000

+1 pour les regex que j'adore !
Mais pas native dans VBA c'est bien dommage :(

juste pour le fun

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
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
Const entete = "<TR class=tete><TH>Nom</TH><TH>lieu</TH><TH>date</TH><TH>soutien</TH><TH>oseille</TH></TR>"
Sub DemoReq3()
    Dim SPQ, lieu, SP, dt, Ps
    With CreateObject("MSXML2.XMLHttp")
        Do
            P% = P% + 1
            .Open "GET", "http://www.kisskissbankbank.com/fr/projects/bigdream/contributors?page=" & P, False
            .setRequestHeader "Accept", "*/*;q=0.5, text/javascript, application/javascript, application/ecmascript, application/x-ecmascript"
            .setRequestHeader "DNT", "1"
            On Error Resume Next
            .send
            On Error GoTo 0
            If .Status = 200 Then
                SPQ = Split(.responsetext, "class=\""username\"">")
                For r% = 1 To UBound(SPQ)
                    lieu = "": fric = ""
                    T$ = T$ & "<TR><TD class=nom>" & Split(SPQ(r), "<")(0)
                    If InStr(SPQ(r), "class=\'amount\'>") > 0 Then fric = Split(Split(SPQ(r), "class=\'amount\'>")(1), "<")(0)
                    If InStr(SPQ(r), "class=\'location\'>") > 0 Then lieu = Split(Split(SPQ(r), "class=\'location\'>")(1), "<")(0)
                    T = T & "</TD><TD class=lieu>" & lieu
                    dt = Split(Split(SPQ(r), "class=\'date-reward\'>\n")(1), "\n")(0)
                    If InStr(SPQ(r), "class=\""count\"">") > 0 Then Ps = Split(Split(SPQ(r), "class=\""count\"">")(1), "<")(0) & " Projets soutenus"
                    T = T & "</TD><TD class=sdate>" & dt & "</TD><TD class=soutien>" & Ps
                    T = T & "</TD><TD class=fric>" & fric
                    T = T & "</TD></TR>" & vbLf
                Next
                If UBound(Split(SPQ(r - 1), ".remove()")) Then Exit Do
            Else
                Exit Do
            End If
        Loop
    End With
 
    If T > "" Then
        T = "<html><TABLE>" & vbLf & entete & vbLf & T & vbLf & "</TABLE></html>"
        Debug.Print T    ' affiche le code html de la table sans style
        With CreateObject("htmlfile")
            .body.innerhtml = T
            Debug.Print .body.innerhtml
            'un peu de style mais maintenant dynamique sans codage
            For Each elem In .all
                Select Case elem.tagname
                Case "TABLE"
                    elem.Style.Border = "3px double green"
                    elem.Style.bordercollapse = "collapse"
                Case "TD"
                    elem.Style.Border = "1px solid black"
                End Select
                Select Case elem.classname
                Case "tete"
                    elem.Style.Background = "#0040FF"
                    elem.Style.Color = "yellow"
                Case "nom"
                    elem.Style.Background = "#F79F81"
                    elem.Style.Color = "#00FF00"
                    elem.Style.fontWeight = "bold"
                Case "lieu"
                    elem.Style.Background = "#F7BE81"
                    elem.Style.Color = "#01DFD7"
                Case "sdate"
                    elem.Style.Background = "#CEF6D8"
                    elem.Style.Color = "#FE2E2E"
                Case "soutien"
                    elem.Style.Background = "#E3CEF6"
                    elem.Style.Color = "#0000FF"
                Case "fric"
                    elem.Style.Background = "#FF0000"
                    elem.Style.Color = "#F7FE2E"
                End Select
            Next
            'on copie sur le sheets le document html tel quel avec le style
            Application.ScreenUpdating = False
            If .parentWindow.clipboardData.setData("Text", .body.innerhtml) Then
                Application.ScreenUpdating = False
                With Sheets(1)
                    .Activate
                    .Cells(1, 1).Select
                    .Paste
                End With
                .parentWindow.clipboardData.clearData "Text"
 
            End If
            codefinal = .body.innerhtml
            Debug.Print codefinal    ' affiche le code html final avec le style (inline)
        End With
 
        Application.ScreenUpdating = True
    End If
    vision_dans_IE codefinal
End Sub
Sub vision_dans_IE(texte)
    With CreateObject("internetexplorer.application")
        .Visible = True
        .navigate "about:blank"
        .document.write texte
    End With
End Sub

excel /html= bonnet blanc /blanc bonnet

02/04/2016, 22h17
cerede2000

Le sujet aura été traité en long, en large, en travers et en diagonale :ptdr::ptdr::ptdr::ptdr::ptdr::ptdr:
02/04/2016, 22h20
patricktoulon

re

tu l a testé?
02/04/2016, 22h22
cerede2000

Yes !
Pourquoi ?

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