Autres Extraire du texte html avec des boucles vba

[Muratime]

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

 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

 

[soan]

Bonjour Muratime,

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

O1:Q1 : vide ; Q1 a ce format personnalisé : jj/mm/aaaa

Ctrl e ➯ en O1 : 80 ; en P1 : F ; en Q1 : 03/09/2020

Option Explicit

Dim chn$

Private Sub Job(s1$, s2$, k As Byte, n As Byte, cel As Range, Optional typ$)
  Dim k1 As Byte, k2 As Byte
  If k = 2 Then k1 = InStrRev(chn, s1, -1, 1) Else k1 = InStr(chn, s1)
  If k1 = 0 Then Exit Sub 's1 non trouvé
  If k = 2 Then k2 = InStrRev(chn, s2, -1, 1) Else k2 = InStr(chn, s2)
  If k2 = 0 Then Exit Sub 's2 non trouvé
  k1 = k1 + n: chn = Mid$(chn, k1, k2 - k1)
  If typ = "d" Then cel = DateValue(chn) Else cel = chn
End Sub

Sub Essai()
  [O1].Resize(, 3).ClearContents 'effacer anciens résultats
  'recherche du nombre de partants ; d'après A1 : 80 ; mis en O1
  chn = [A1]: If chn <> "" Then Job "- ", " ", 2, 2, [O1]
  'recherche du type de course ; d'après A2 : F ; mis en P1
  chn = [A2]: If chn <> "" Then Job "Course ", ",", 2, 7, [P1]
  'recherche de la date ; d'après A3 : 03/09/2020 ; mis en Q1
  chn = [A3]: If chn <> "" Then Job " ", " -", 1, 1, [Q1], "d"
End Sub

soan

 

[patricktoulon]

bonjour
si tu veux que l'on te montre comment extraire le innertext d'une partie d'un document html faudrait il encore nous donner le code html ou le lien de la page
en l’état le text que tu donne n'est que du text et ne concerne donc pas le html

 

[Muratime]

Salut merci pour les réponses, donc je joins le fichier qui est lié avec ma page perso et surtout j'aimerais conserver mon format de ma macro, j'ai juste besoin de la 3ème boucle For qui trouve la lettre après le mot course et si au quel cas il ne trouve pas le mot course F ( la lettre peu changer) alors il me remplace le rien par Gr.
Dans tous les cas il y aura course + espace + une lettre + une virgule.
Merci de votre aide c'est super cool 😉
Au passage je voulais savoir cela correspond a quoi Chr$(13) & Chr$(10)

 

[patricktoulon]

re
et bien voila on avance
seul le lien me suffit voici un petit code model
regarde les msgbox 😉

Sub test()
    Dim matableRalye, elem, mesBalisesP, P
    Url = "http://simple.gagnant.place.free.fr/page5.html"
    With CreateObject("htmlfile")
        .body.innerhtml = DataHtml(Url)
        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
            ' tu fait ce que tu veux des lignes ici
            Next
        End If
    End With

End Sub


Function DataHtml(Url)
    Dim REQ
    Set REQ = CreateObject("microsoft.xmlhttp")
    With REQ
        .Open "GET", Url, False
        .setRequestHeader "User-Agent", "Mozilla/5.0 (Windows NT 6.1; WOW64; Trident/7.0; rv:11.0) like Gecko"
        .send
        DataHtml = .responsetext
    End With
End Function

 

[sylvanu]

Bonjour Muratime, Patrick, Soan,
Peut être en rajoutant un test dans le code existant sans changer sa structure:

If Elem.Rows(1).innerText = "Aucun résultat" Then GoTo SAUT


' Regarde si la chaine contient Course, dans ce cas on prend 8 caractères
If Not IsError(Application.Find("Course", Elem.innerText)) Then
       PosCourse = Application.Find("Course", Elem.innerText)
       Course = Mid(Elem.innerText, PosCourse, 8)
End If


For i = 1 To Elem.Rows.Length - 1 Step 2

 

[patricktoulon]

bonjour sylvanu
le travail demandé exige un peu de travail string car !!!
ce n'est pas un tableau ou même un sous tableau(balise table dans un td)
c'est un div qui est dans un td
ce div contient 5 balises P contenant les lignes que tu vois a l’Écran

comme je te l'ai montré
tu get le div par sa classe
tu get ensuite les enfants (balises P)

le reste n'est que du split (travaux string en vba)

exemple pour le nombres de partant
MsgBox Split(Split(mesBalisesP(1).innerText, "- ")(2), " ")(0)
ou meme
MsgBox Val(Mid(mesBalisesP(1).innerText, InStrRev(mesBalisesP(1).innerText, "- ") + 2))

 

[sylvanu]

@patrick,
Ne voulant pas casser la structure du code de Muratime comme demandé, j'ai juste réutilisé son extraction.
Et comme Elem.Rows(1).innerText contient :

DateVILLEDISTCAT----------[+]
16/08/2020SAINT JULIEN5000mF--------[+-]
RALLYE
Special - 5000m - 80 partants
16.000 Euros - Spécial, homes. - Course F, 5.000 mètres.
Jeudi 03 Septembre 2020 - SAINT JULIEN

Je l'ai réutilisé. C'était juste une suggestion.

 

[patricktoulon]

re
oui c'est une solution ,mais tu a plus de travail en string pour chopper les données que tu souhaite
alors qu'avec ma méthode tu a ligne par ligne ça dégrossis pas mal le job pour la dissection

 

[sylvanu]

Attention. je n'ai jamais dit que votre solution n'était pas bien meilleure. C'est d'ailleurs par une telle approche, avec moins de brio, que j'aurais procédé. Elle est plus propre et mieux structurée.
Mais j'ai lu le "surtout", d'où ma proposition.

et surtout j'aimerais conserver mon format de ma macro

 

[patricktoulon]

re
oui t'inquiet je prends rien de mal
parfois mieux vaut bousculer les a priori du demandeur plutôt que de le laisser s’empêtrer dans un
truc de fou
et surtout (par ce que connaissant bien la chose) il n'est pas dit que le code (structure de la page web ne change pas)
et là ben faut tout refaire
alors q'une analyse structurelle du DOM DANS code? sera bien plus efficiente et plus facile a remodeler 😉
IL suffit que demain il est 2 courses avant "RALYE"(aujourd'hui il n'y en a qu'une)
ben l’analyse par les cell et/rows ben bye bye!! 😀

 

[Muratime]

Bon merci pour toutes vos réponses, 😛😀 donc je vais commencer par le premier code celui a patricktoulon

Donc dans un premier temps je voulais savoir si les trois variable matableRalye, mesBalisesP, et p, était de type object ? C'est ce que j'ai mis.
Ensuite j'aurais voulu qu'il colle le résultat dans la colonne P la il me la met en colonne E.
Ensuite il y a le truc que s'il trouve pas le mot course F, ou course G, etc qu'il mette Gr dans la colonne P, j'ai modifié ma page ou on pourra retrouver les trois types de texte. Ensuite je m’aperçois qu'il ne fonctionne qu'avec le premier sous tableau avec la nouvelle page.
Donc le premier sous tableau contient Course F mais les deux du dessous non et donc on remplace par Gr.

Voici le code donc que j'ai mis

Option Explicit

Sub Lire_Courses()
    Dim ws As Worksheet, Cel As Range
    Dim Doc As Object, Elem As Object
    Dim A() As Variant, TB() As String, Tdate
    Dim i As Integer, j As Integer, Lig As Integer
    Dim nomPi As String, nbPi As Byte, numPi As Byte
    Dim nomCrse As String, nbCrse As String, Temp As String
    Dim matableRalye As Object, mesBalisesP As Object, p As Object
    'Boucle
    With F04
        .Activate
        Cells.Delete
        nbCrse = Val(Right(F03.Cells(F03.[A500].End(xlUp).Row, 1), 2))
        For Each Cel In F03.Range("C3:C" & F03.[C500].End(xlUp).Row)
            If CBool(Cel.Hyperlinks.Count) Then
                nomPi = Cel: nomCrse = Cel.Offset(, -2):
                numPi = Val(Cel.Offset(, -1)): nbPi = Val(Cel.Offset(, 3))
                Url = Cel.Hyperlinks(1).Address
            
                Cells.Delete
              
                Set Doc = CreateObject("HtmlFile")
                With Doc
                    .body.innerhtml = DataHtml(Url)
                    Set Elem = .getelementbyid("fc_table_recettes")
                    If Elem.Rows(1).innerText = "Aucun résultat" Then GoTo SAUT
                    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
                        Temp = Split(Elem.Rows(i + 1).Cells(0).outerText, Chr$(13) & Chr$(10))(1)
                        Cells((i + 1) / 2, 15) = Val(Split(Temp, "-")(2))
                    Next i
                 ''''''''''''''''''''''''''''''''''''''''''''''''''
                   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
                ' tu fait ce que tu veux des lignes ici
            Next
        End If
    ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
                  
                End With
                Columns("F").Delete
                Columns("B").Insert
                Range("B1:B" & [A500].End(xlUp).Row) = nomPi
              
            End If
SAUT:
        Next Cel
      
    End With
End Sub

avec le fichier

 

[patricktoulon]

re
et oui tu vois elle a changée depuis tout a l'heure
Alors prends le temps d’analyser
tu peux même travailler sur un fichier vierge
colle ce code dans un module et lance la sub test

Option Explicit
Type coursse
    partants As Long
    Lieu As String
    Date As String
    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 = "http://simple.gagnant.place.free.fr/page5.html"
    course = GetDatacourse(Url)
    t = "lieu de la course  :  " & course.Lieu & vbCrLf
    t = t & "date le la course  :  " & course.Date & vbCrLf
    t = t & "nombre de paratants : " & course.partants & vbCrLf
    t = t & "category de la course: " & course.Category & vbCrLf
    t = t & "sexe category        : " & course.sexeCategory & vbCrLf
    t = t & "distance à parcourir :" & course.Distance & vbCrLf
    t = t & "prix de la course  :  " & course.Prix & vbCrLf

    MsgBox t
    'MsgBox course.TextComplet
End Sub


Function GetDatacourse(Url) As coursse
    Dim REQ, co As coursse, code$
    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)
            co.Date = Split(mesBalisesP(mesBalisesP.Length - 1).innerText, " -")(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

démonstration

 

[Muratime]

Ensuite le code de
sylvanu

Idem ça donne le même résultat que patricktoulon, ensuite tes deux variable PosCourse et course j'ai mis de type string

Option Explicit

Sub Lire_Courses()
    Dim ws As Worksheet, Cel As Range
    Dim Doc As Object, Elem As Object
    Dim A() As Variant, TB() As String, Tdate
    Dim i As Integer, j As Integer, Lig As Integer
    Dim nomPi As String, nbPi As Byte, numPi As Byte
    Dim nomCrse As String, nbCrse As String, Temp As String
    Dim PosCourse As String, Course As String
  
    'Boucle
    With F04
        .Activate
        Cells.Delete
        nbCrse = Val(Right(F03.Cells(F03.[A500].End(xlUp).Row, 1), 2))
        For Each Cel In F03.Range("C3:C" & F03.[C500].End(xlUp).Row)
            If CBool(Cel.Hyperlinks.Count) Then
                nomPi = Cel: nomCrse = Cel.Offset(, -2):
                numPi = Val(Cel.Offset(, -1)): nbPi = Val(Cel.Offset(, 3))
                Url = Cel.Hyperlinks(1).Address
              
                Cells.Delete
                
                Set Doc = CreateObject("HtmlFile")
                With Doc
                    .body.innerhtml = DataHtml(Url)
                    Set Elem = .getelementbyid("fc_table_recettes")
                    If Elem.Rows(1).innerText = "Aucun résultat" Then GoTo SAUT
                    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
                        Temp = Split(Elem.Rows(i + 1).Cells(0).outerText, Chr$(13) & Chr$(10))(1)
                        Cells((i + 1) / 2, 15) = Val(Split(Temp, "-")(2))
                    Next i
                    ''''''''''''''''''''''''''''''''''''''''''''''
                    ' Regarde si la chaine contient Course, dans ce cas on prend 8 caractères
                    If Not IsError(Application.Find("Course", Elem.innerText)) Then
                    PosCourse = Application.Find("Course", Elem.innerText)
                    Course = Mid(Elem.innerText, PosCourse, 8)
                    End If
                    ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
                End With
                Columns("F").Delete
                Columns("B").Insert
                Range("B1:B" & [A500].End(xlUp).Row) = nomPi
                
            End If
SAUT:
        Next Cel
        
    End With
End Sub

et le fichier

 

[patricktoulon]

allez pour la peine j'ai remanier la date pour qu'elle soit exploitable en vba ou excel

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 = "http://simple.gagnant.place.free.fr/page5.html"
    course = GetDatacourse(Url)
    t = "lieu de la course  :  " & course.Lieu & vbCrLf
    t = t & "date le la course  :  " & course.DateX & vbCrLf
    t = t & "nombre de paratants : " & course.partants & vbCrLf
    t = t & "category de la course: " & course.Category & vbCrLf
    t = t & "sexe category        : " & course.sexeCategory & vbCrLf
    t = t & "distance à parcourir :" & course.Distance & vbCrLf
    t = t & "prix de la course  :  " & course.Prix & vbCrLf

    MsgBox t
    '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
        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

en fait dans la sub test tu fait ce que tu veux de

1. course.lieu
2. course.dateX
3. course.prix
4. course.category
5. course.distance
6. etc..etc..

😉