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
M

Muratime

XLDnaute Junior
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. :confused: car là j'ai le cerveau qui fume :D
 
Vote positif 0 Vote négatif
patricktoulon

patricktoulon

XLDnaute Barbatruc
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
demo6.gif


c'est pas plus compliqué que ça ?
 
Vote positif 0 Vote négatif
M

Muratime

XLDnaute Junior
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
 
Vote positif 0 Vote négatif
M

Muratime

XLDnaute Junior
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 :D .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
 
Dernière édition:
Vote positif 0 Vote négatif
patricktoulon

patricktoulon

XLDnaute Barbatruc
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 :D .Maintenant que j'ai le cerveau grillé j'ai plus qu'a aller me faire des crêpes
Cliquez pour agrandir...
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 :p :p :D :D :cool: :oops: :rolleyes:o_O;)
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 ;):p
 
Vote positif 0 Vote négatif
patricktoulon

patricktoulon

XLDnaute Barbatruc
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????
 
Vote positif 0 Vote négatif
S

soan

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

soan
 
Vote positif 0 Vote négatif
patricktoulon

patricktoulon

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

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

4 membres et 60 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