Autres Extraire du texte html avec des boucles vba

Muratime · 13 Septembre 2020

Bonjour forum

J'ai deux boucles for et j'aimerais en rajouter une 3ème mais je coince.
Dans une page HTML j'ai ceci un mini tableau.

Et j'ai ce code

VB:

 For i = 1 To Elem.Rows.Length - 1 Step 2
                        For j = 0 To Elem.Rows(i).Cells.Length - 1
                            If j = 0 Then
                                Tdate = Split(Elem.Rows(i).Cells(j).outerText, "/")
                                Cells((i + 1) / 2, j + 1) = DateSerial(Tdate(2), Tdate(1), Tdate(0))
                            Else
                                Cells((i + 1) / 2, j + 1) = IIf(j = 5, Val(Elem.Rows(i).Cells(j).outerText), Elem.Rows(i).Cells(j).outerText)
                            End If
                        Next j
                        Feuil1 = Split(Elem.Rows(i + 1).Cells(0).outerText, Chr$(13) & Chr$(10))(1)
                        Cells((i + 1) / 2, 15) = Val(Split(Feuil1, "-")(2))
                  
                    Next i

La boucle (i) encadré rouge va me sortir le chiffre 80 sur la Feuil1 colonne 15
et la boucle (j) encadré bleu va me garder la date dans ce format là 03/09/2020
et ce que j'aurais besoin en plus dans ce code se trouve dans l'encadré vert et je voudrais garder que le F avant le mot course et qui le colle sur Feuil1 et colonne 16.

Voilà si quelqu'un pouvais m'aider mer ci beaucoup.

je met le texte ici

Spécial - 5000m - 80 partants
16.000 Euros - Spécial, homes. - Course F, 5.000 mètres.
Jeudi 03 Septembre 2020 - SAINT JULIEN

patricktoulon · 14 Septembre 2020

Bonjour
là tu récupere toutes les courses sur ce model on passe en tableau variable plus en classe

VB:

Option Explicit
Public Url As String

Sub test()
    Dim lescourses, t$, Url$, tbl
    Url = "http://simple.gagnant.place.free.fr/page6.html"
    lescourses = GetDatacourse(Url)
    Sheets(1).Cells(Rows.Count, 1).End(xlUp).Offset(1).Resize(UBound(lescourses), 7) = lescourses
End Sub


Function GetDatacourse(Url)
    Dim REQ, co(), code$, d, q&
    Dim matableRalye, elem, mesBalisesP, P
    Set REQ = CreateObject("microsoft.xmlhttp")
    With REQ: .Open "GET", Url, False: .send: code = .responsetext: End With

    With CreateObject("htmlfile")
        .body.innerhtml = code
        For Each elem In .all
            If...

Muratime · 13 Septembre 2020

Re patricktoulon, alors j'ai essayé un peu ton code mais par contre moi ce que je voulais c'est garder mon code original avec son lien en Feuil Index enfin tous quoi, mes deux première boucle fonctionnent, il me faut juste la 3ème, j'ai aussi dans le module divers une fonction, car j'avoue que je suis complètement perdu avec tout ce code, j'ai juste besoin de l'essentiel. car là j'ai le cerveau qui fume

patricktoulon · 13 Septembre 2020

tu a le cerveau qui fume parce que je te sort de ton confort et tu n'a pas ecouté ce que j'ai dit plus haut
je t'ai proposé un code (encore améliorable mais solide) de facon a ce que tu n'ai rien a faire

c'est pourtant tres simple tu touche que la sub test
et tu fait ce que tu veux avec les element de la classe coursse (par le type coursse)

tu met les éléments ou tu veux
exemple je met tout sur une ligne dans la feuille

VB:

Option Explicit
Type coursse
    partants As Long
    Lieu As String
    DateX As Date
    Distance As Long
    Prix As Long
    TextComplet As String
    Category As String
    sexeCategory As String
End Type
Sub test()
    Dim course As coursse, t$, url$, tbl
    url = "http://simple.gagnant.place.free.fr/page5.html"
    course = GetDatacourse(url)
    With course: tbl = Array(.Lieu, .DateX, .Distance, .Prix, .partants, .Category, .sexeCategory): End With
    Sheets(1).[A1].Resize(, UBound(tbl) + 1) = tbl
    'course.TextComplet
End Sub


Function GetDatacourse(url) As coursse
    Dim REQ, co As coursse, code$, d
    Dim matableRalye, elem, mesBalisesP, P
    Set REQ = CreateObject("microsoft.xmlhttp")
    With REQ: .Open "GET", url, False: .send: code = .responsetext: End With

    With CreateObject("htmlfile")
        .body.innerhtml = code
        For Each elem In .all
            If elem.className = "FicheTabIntChapo" Then Set matableRalye = elem
        Next
        If Not matableRalye Is Nothing Then
            Set mesBalisesP = matableRalye.getElementsByTagName("P")
            'For Each P In mesBalisesP: MsgBox P.innerText: Next
            co.TextComplet = matableRalye.innerText
            co.partants = Split(Split(mesBalisesP(1).innerText, "- ")(2), " ")(0)
            co.Prix = Val(Replace(Split(mesBalisesP(2).innerText, " -")(0), ".", ""))
            co.Category = "Gr"
            If InStr(1, mesBalisesP(2).innerText, "Course ") > 0 Then co.Category = Split(Split(mesBalisesP(2).innerText, "Course ")(1), ",")(0)
            d = Split(mesBalisesP(mesBalisesP.Length - 1).innerText, " -")(0)
            co.DateX = DateValue(Replace(d, Split(d, " ")(0), ""))
            co.Lieu = Split(mesBalisesP(mesBalisesP.Length - 1).innerText, " -")(1)
            co.sexeCategory = Split(mesBalisesP(2).innerText, " -")(1)
            co.Distance = Val(Trim(Split(mesBalisesP(1).innerText, "-")(1)))
        End If
    End With
    GetDatacourse = co
End Function

après tu fait comme tu veux si tu veux continuer avec ta méthode
je te laisse là avec ton code et dans les méandres de toutes les erreurs qui seront déclenchées
au moindre changement de la page sans que tu puisse déboguer sans tout re coder

en tout cas il est hors de question que je m'amuse a déboguer ton code et a lui mettre des patchs a chaque fois que la page va changer

prends le temps d’analyser et les bonnes décisions
démo

c'est pas plus compliqué que ça ?

Muratime · 13 Septembre 2020

Il manque la variable URL ! Ensuite si je met comme toi dans un classeur nouveau, j'ai juste une message box qui s'affiche et c'est tout ! Si je clique n'importe ou il n' a rien qui se passe cela ne met rien dans Feuil1 en tous cas pas comme dans ton GIF. Le but de la manœuvre ce serait de mettre la boucle dans le sub pas dans la fonction car tu imagines bien que je ne vais pas cliquer pour chaque lien lol J'en aurais plusieurs. Tu pourrais m'envoyer ton fichier, je suis sur excel 2007 peut être ça

Muratime · 13 Septembre 2020

Bon déjà ce que j'ai compris soit tu m'as mis des trolls exprès ou soit c'est mon excel qui est pourri ce que je doute j'ai demandé a un pote d'ouvrir le fichier sur 2019 donc ça venait pas de chez moi mdrr
Ici la variables URL pas déclaré J'ai mis Dim URL As String on peu aussi mettre en dessous du Option Explicit Public Url As String
Et le Sheets(1) ça fonctionne mieux avec Sheets ("Feuil1") avec un nouveau classeur c'est rare que la feuille s'appel 1 toute seul .Maintenant que j'ai le cerveau grillé j'ai plus qu'a aller me faire des crêpes hahaha.

Voici la correction

VB:

Option Explicit
Public Url As String
Type coursse
    partants As Long
    Lieu As String
    DateX As Date
    Distance As Long
    Prix As Long
    TextComplet As String
    Category As String
    sexeCategory As String
End Type
Sub test()
    Dim course As coursse, t$, Url$, tbl
    Url = "http://simple.gagnant.place.free.fr/page5.html"
    course = GetDatacourse(Url)
    With course: tbl = Array(.Lieu, .DateX, .Distance, .Prix, .partants, .Category, .sexeCategory): End With
    Sheets("Feuil1").[A1].Resize(, UBound(tbl) + 1) = tbl
    'course.TextComplet
End Sub


Function GetDatacourse(Url) As coursse
    Dim REQ, co As coursse, code$, d
    Dim matableRalye, elem, mesBalisesP, P
    Set REQ = CreateObject("microsoft.xmlhttp")
    With REQ: .Open "GET", Url, False: .send: code = .responsetext: End With

    With CreateObject("htmlfile")
        .body.innerhtml = code
        For Each elem In .all
            If elem.className = "FicheTabIntChapo" Then Set matableRalye = elem
        Next
        If Not matableRalye Is Nothing Then
            Set mesBalisesP = matableRalye.getElementsByTagName("P")
            'For Each P In mesBalisesP: MsgBox P.innerText: Next
            co.TextComplet = matableRalye.innerText
            co.partants = Split(Split(mesBalisesP(1).innerText, "- ")(2), " ")(0)
            co.Prix = Val(Replace(Split(mesBalisesP(2).innerText, " -")(0), ".", ""))
            co.Category = "Gr"
            If InStr(1, mesBalisesP(2).innerText, "Course ") > 0 Then co.Category = Split(Split(mesBalisesP(2).innerText, "Course ")(1), ",")(0)
            d = Split(mesBalisesP(mesBalisesP.Length - 1).innerText, " -")(0)
            co.DateX = DateValue(Replace(d, Split(d, " ")(0), ""))
            co.Lieu = Split(mesBalisesP(mesBalisesP.Length - 1).innerText, " -")(1)
            co.sexeCategory = Split(mesBalisesP(2).innerText, " -")(1)
            co.Distance = Val(Trim(Split(mesBalisesP(1).innerText, "-")(1)))
        End If
    End With
    GetDatacourse = co
End Function

patricktoulon · 13 Septembre 2020

ci la variables URL pas déclaré J'ai mis Dim URL As String on peu aussi mettre en dessous du Option Explicit Public Url As String
Et le Sheets(1) ça fonctionne mieux avec Sheets ("Feuil1") avec un nouveau classeur c'est rare que la feuille s'appel 1 toute seul .Maintenant que j'ai le cerveau grillé j'ai plus qu'a aller me faire des crêpes

oui je crois que toi et ton pc avez serré mon pauvre
elle n'est pas déclarrée "url dans la sub?

VB:

Sub test()
    Dim course As coursse, t$, Url$, tbl
    Url = "http://simple.gagnant.place.free.fr/page5.html"
'...
'...

et le 1 dans "sheets(1)" le 1 c'est pas le nom c'est l'index sinon il serait entre guillemets

ouais ta serré mon pauvre

si tu a un bug qui est insensé très souvent c'est une ref manquante qui créée des erreur complètement absurdes
mais bon pour toi là c'est la boite de dolliprane

Muratime · 13 Septembre 2020

Bref je crois qu'il y a une modif a faire pour la lettre a trouver car par exemple, j'ai fais une nouvelle page le cas sera présent et ça donne Gr mais en réalité ça devrais donner B tu changes le lien par celui là

http://simple.gagnant.place.free.fr/page6.html

Pour ça qu'il faut qu'il trouve Course + espace + la lettre + la virgule

patricktoulon · 13 Septembre 2020

ok je vais voir

patricktoulon · 13 Septembre 2020

voila
comme tu peux le constater quand un code est bien construit il est facile de le modifier

VB:

Option Explicit
Public Url As String
Type coursse
    partants As Long
    Lieu As String
    DateX As Date
    Distance As Long
    Prix As Long
    TextComplet As String
    Category As String
    sexeCategory As String
End Type
Sub test()
    Dim course As coursse, t$, Url$, tbl
    Url = "http://simple.gagnant.place.free.fr/page6.html"
    course = GetDatacourse(Url)
    With course: tbl = Array(.Lieu, .DateX, .Distance, .Prix, .partants, .Category, .sexeCategory): End With
    Sheets("Feuil1").[A1].Resize(, UBound(tbl) + 1) = tbl
    MsgBox course.TextComplet
End Sub


Function GetDatacourse(Url) As coursse
    Dim REQ, co As coursse, code$, d
    Dim matableRalye, elem, mesBalisesP, P
    Set REQ = CreateObject("microsoft.xmlhttp")
    With REQ: .Open "GET", Url, False: .send: code = .responsetext: End With

    With CreateObject("htmlfile")
        .body.innerhtml = code
        For Each elem In .all
            If elem.className = "FicheTabIntChapo" Then Set matableRalye = elem: Exit For
        Next
        If Not matableRalye Is Nothing Then
            Set mesBalisesP = matableRalye.getElementsByTagName("P")
            'For Each P In mesBalisesP: MsgBox P.innerText: Next
            co.TextComplet = matableRalye.innerText
            co.partants = Split(Split(mesBalisesP(1).innerText, "- ")(2), " ")(0)
            co.Prix = Val(Replace(Split(mesBalisesP(2).innerText, " -")(0), ".", ""))
            co.Category = "Gr"
            If InStr(1, mesBalisesP(2).innerText, "Course ") > 0 Then co.Category = Split(Split(mesBalisesP(2).innerText, "Course ")(UBound(Split(mesBalisesP(2).innerText, "Course "))), ",")(0)
            d = Split(mesBalisesP(mesBalisesP.Length - 1).innerText, " -")(0)
            co.DateX = DateValue(Replace(d, Split(d, " ")(0), ""))
            co.Lieu = Split(mesBalisesP(mesBalisesP.Length - 1).innerText, " -")(1)
            co.sexeCategory = Split(mesBalisesP(2).innerText, " -")(1)
            co.Distance = Val(Trim(Split(mesBalisesP(1).innerText, "-")(1)))
        End If
    End With
    GetDatacourse = co
End Function

petite question
tu veux en récupérer qu'un ou tout les rallye????

Muratime · 13 Septembre 2020

Tous serait bien car là il ne prend que le premier

soan · 13 Septembre 2020

Bonsoir Muratime,

Dans ton post #4 tu as écrit :

« Au passage je voulais savoir cela correspond à quoi Chr$(13) & Chr$(10) »

C'est le couple de caractères CR / LF, dont l'origine remonte aux vieux écrans
en mode texte, et même avant, avec les telex et les machines à écrire :

Chr$(13) est le code ASCII 13 ; ça correspond à Carriage Return (retour chariot) ;
le curseur de texte retourne en début de ligne ; ou le chariot de la machine à
écrire retourne complètement à gauche, au début de la ligne de texte.

Chr$(10) est le code ASCII 10 ; ça correspond à Line Feed (saut de ligne) ;
le curseur de texte passe à la ligne suivante (juste dessous) ; ou le chariot
de la machine à écrire « monte d'un cran » (et lève donc la feuille) ➯
la suite des caractères tapés se fait sur la ligne en dessous.

Comme quoi, même dans l'informatique actuelle moderne, il reste encore
des résidus néandertaliens de la préhistoire informatique !

soan

Muratime · 13 Septembre 2020

Bah sympa l'explication c'est peu être préhistorique mais quand j'ai essayé excel 2019 avec l'enregistreur de macro et son insertion tableau tout près avec les tables dans la macro enregistré il y avait aussi Chr$(13) & Chr$(10)

patricktoulon · 14 Septembre 2020

Bonjour
là tu récupere toutes les courses sur ce model on passe en tableau variable plus en classe

VB:

Option Explicit
Public Url As String

Sub test()
    Dim lescourses, t$, Url$, tbl
    Url = "http://simple.gagnant.place.free.fr/page6.html"
    lescourses = GetDatacourse(Url)
    Sheets(1).Cells(Rows.Count, 1).End(xlUp).Offset(1).Resize(UBound(lescourses), 7) = lescourses
End Sub


Function GetDatacourse(Url)
    Dim REQ, co(), code$, d, q&
    Dim matableRalye, elem, mesBalisesP, P
    Set REQ = CreateObject("microsoft.xmlhttp")
    With REQ: .Open "GET", Url, False: .send: code = .responsetext: End With

    With CreateObject("htmlfile")
        .body.innerhtml = code
        For Each elem In .all
            If elem.className = "FicheTabIntChapo" Then
                Set matableRalye = elem
                q = q + 1
                ReDim Preserve co(1 To 8, 1 To q)
                Set mesBalisesP = matableRalye.getElementsByTagName("P")
                'For Each P In mesBalisesP: MsgBox P.innerText: Next
                co(8, q) = matableRalye.innerText    '.TextComplet
                co(2, q) = Split(Split(mesBalisesP(1).innerText, "- ")(2), " ")(0)    '.partants
                co(3, q) = Val(Replace(Split(mesBalisesP(2).innerText, " -")(0), ".", ""))    '.Prix
                co(4, q) = "Gr"    '.Category
                If InStr(1, mesBalisesP(2).innerText, "Course ") > 0 Then co(4, q) = Split(Split(mesBalisesP(2).innerText, "Course ")(UBound(Split(mesBalisesP(2).innerText, "Course "))), ",")(0)
                d = Split(mesBalisesP(mesBalisesP.Length - 1).innerText, " -")(0)
                co(5, q) = DateValue(Replace(d, Split(d, " ")(0), ""))    '.DateX
                co(1, q) = Split(mesBalisesP(mesBalisesP.Length - 1).innerText, " -")(1)    '.Lieu
                co(6, q) = Split(mesBalisesP(2).innerText, " -")(1)    '.sexeCategory
                co(7, q) = Val(Trim(Split(mesBalisesP(1).innerText, "-")(1)))    '.Distance
            End If
        Next
    End With
    GetDatacourse = Application.Transpose(co)
End Function

Muratime · 14 Septembre 2020

Bon bah merci a tous et surtout a Patricktoulon, je pense que j'ai tous ce qu'il me fallait, au quel cas je repasserais par là.

Autres Extraire du texte html avec des boucles vba

Muratime

XLDnaute Junior

patricktoulon

Muratime

XLDnaute Junior

patricktoulon

XLDnaute Barbatruc

Muratime

XLDnaute Junior

Muratime

XLDnaute Junior

patricktoulon

XLDnaute Barbatruc

Muratime

XLDnaute Junior

patricktoulon

XLDnaute Barbatruc

patricktoulon

XLDnaute Barbatruc

Muratime

XLDnaute Junior

soan

XLDnaute Barbatruc

Muratime

XLDnaute Junior

patricktoulon

XLDnaute Barbatruc

Muratime

XLDnaute Junior

Discussions similaires