Autres Extraire du texte html avec des boucles vba

M

Muratime

XLDnaute Junior
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.
split.png

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
 
Dernière édition:
Solution
patricktoulon
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...
Trier par date Trier par votes
S

soan

XLDnaute Barbatruc
Inactif
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
VB: 
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
 

Pièces jointes

  • Exo Muratime.xlsm
    16.5 KB · Affichages: 18
Dernière édition:
Vote positif 0 Vote négatif
M

Muratime

XLDnaute Junior
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)
 

Pièces jointes

  • Fichier_test.xlsm
    62.9 KB · Affichages: 15
Dernière édition:
Vote positif 0 Vote négatif
patricktoulon

patricktoulon

XLDnaute Barbatruc
re
et bien voila on avance
seul le lien me suffit voici un petit code model
regarde les msgbox ;)
VB: 
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
 
Vote positif 0 Vote négatif
sylvanu

sylvanu

XLDnaute Barbatruc
Supporter XLD
Bonjour Muratime, Patrick, Soan,
Peut être en rajoutant un test dans le code existant sans changer sa structure:
VB: 
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
 
Vote positif 0 Vote négatif
patricktoulon

patricktoulon

XLDnaute Barbatruc
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
Capture.JPG

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))
 
Dernière édition:
Vote positif 0 Vote négatif
sylvanu

sylvanu

XLDnaute Barbatruc
Supporter XLD
@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 :
VB: 
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.
 
Vote positif 0 Vote négatif
patricktoulon

patricktoulon

XLDnaute Barbatruc
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!! :D
 
Vote positif 0 Vote négatif
M

Muratime

XLDnaute Junior
Bon merci pour toutes vos réponses, :p:D 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
VB: 
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
 

Pièces jointes

  • Fichier_test.xlsm
    62.9 KB · Affichages: 10
Dernière édition:
Vote positif 0 Vote négatif
patricktoulon

patricktoulon

XLDnaute Barbatruc
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
VB: 
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
demo6.gif
 
Vote positif 0 Vote négatif
M

Muratime

XLDnaute Junior
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
Code: 
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
 

Pièces jointes

  • Fichier_test_2.xlsm
    62.9 KB · Affichages: 6
Vote positif 0 Vote négatif
patricktoulon

patricktoulon

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

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 = "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..
;)
 
Vote positif 0 Vote négatif

Discussions similaires

M
  • Question
XL 2010 Aide à la suppression d'un produit en double dans un magasin spécifique avec conditions
Réponses
9
Affichages
660
Mody200
M
Nicolas JACQUIN
  • Question
XL 2021 Exportation feuille msgbox yes no avec module Thisworkbook
2
Réponses
21
Affichages
889
Nicolas JACQUIN
Nicolas JACQUIN
C
  • Résolu(e)
XL 2021 Remplir données devis en vba avec descriptions/quantités/PUs alignés
2
Réponses
18
Affichages
985
Phil69970
Phil69970
U
  • Résolu(e)
Autres Mettre en couleur ligne avec VBA car MFC occupées (Excel 2003)
2
Réponses
15
Affichages
1 K
un internaute
U
G
  • Résolu(e)
XL 2016 Définir Boucle pour afficher plusieurs tableaux dans des textbox sur une userform (ou sur une feuille Excel)
Réponses
6
Affichages
1 K
gaby.jvx
G
S
  • Résolu(e)
Microsoft 365 automatiser macro pour copier/coller des données d´un classeur à un autre et sauver à chaque fois le classeur rempli
Réponses
8
Affichages
4 K
sevenkingdom
S
Nicolas JACQUIN
  • Question
XL 2016 Optimisation code agenda
Réponses
0
Affichages
1 K
Nicolas JACQUIN
Nicolas JACQUIN
patricktoulon
  • Question
indenter un code html par vba
Réponses
4
Affichages
1 K
patricktoulon
patricktoulon
O
  • Question
XL 2019 Excel VBA - Condition selon le nom du fichier
Réponses
5
Affichages
2 K
Staple1600
Staple1600
N
  • Question
Macro à améliorer
Réponses
1
Affichages
814
Pounet95
P

Membres actuellement en ligne

2 membres et 53 invités.

Partager cette page

Tutos vidéos

Power Query : Ajouter des requêtes (Excel et Power BI)
Créez votre première fonction LAMBDA dans Excel en 3 étapes!
LAMBDA, l’arme secrète de Microsoft pour Excel !
Office Insider - Découvrez les nouveautés Excel avant tout le monde

Statistiques des forums

Discussions
314 655
Messages
2 111 604
Membres
111 217
dernier inscrit
aladinkabeya2