Import de page web sur Excel

bon j'aimerais bien que tout se fasse en auto sur chaque ligne.. snirfll

Intéressant !

Au passage, une autre formule pour transformer le résultat en URL :

=SUBSTITUE(A3;"about:";$E$2)

On peut ensuite si besoin récupérer le n° de la course par

=STXT(E3;CHERCHE("_";E3)+1;8)

Une question de compréhension ... où cherches-tu le lien avec cette macro -qui est très intéressante- ?

Sub ExtractionLiensHypertextes()
    Dim Cell As Range
    Dim Ligne As Integer

    'Récupère le numéro de la dernière ligne non vide
    Ligne = Columns(5).SpecialCells(xlCellTypeLastCell).Row

    'Boucle sur les cellules de la colonne A
    For Each Cell In Range("e3:e" & Ligne)
        If Cell.Hyperlinks.Count > 0 Then _
            Cell.Offset(0, 6) = Cell.Hyperlinks(1).Address
    Next Cell
End Sub

bon j'aimerais bien que tout se fasse en auto sur chaque ligne.. snirfll

solution 1 :

Je ne suis pas très à l'aise avec Queries.Add mais tu étais bien parti en créant une nouvelle requête sur une nouvelle page. Mais ensuite on a toute la page, pas facile à exploiter.

solution 2 :

Je suppose que ta seconde feuille est faite avec PowerQuery ... l'ennui c'est qu'on va se retrouver sans les URL des chevaux.

solution 3 :

Personnellement, je reprendrais la même macro avec getElementsByTagName("a") de la façon suivante :

  • ouvrir une nouvelle feuille pour chaque course
  • reporter l'url en cellule A3
  • déclencher pour chaque feuille la macro Go renommée en OnYVa car cela ne passait pas ...
Sub PartantsParCourse()
Dim i%, sw As Worksheet

With Sheets("Feuil1")
    For i = 3 To .Range("E" & Rows.Count).End(xlUp).Row
        Set sw = Sheets.Add
        sw.Select
        Range("A2") = .Range("E" & i)
        Range("B2") = "/cheval/"
        OnYVa ' macro de base ré-appliquée à chaque feuille ajoutée
    Next
End With

End Sub

Macro complète car changement du nom Go en OnYVa

Option Explicit

Sub OnYVa()
 Dim page As New HTMLDocument, lien As Object, lig As Integer, url As String

    ' effacement
    Range("A1").CurrentRegion.Offset(2, 0).ClearContents

    ' création de l'objet page avec comme contenu le site
    url = Range("A2").Value
    page.body.innerHTML = pageHTML(url)

    ' recherche des liens contenant un mot-clé
    lig = 3
    For Each lien In page.getElementsByTagName("a")
        url = lien.getAttribute("HREF")
        If url Like "*" & Range("B2").Value & "*" Then
            Cells(lig, 1) = url
            lig = lig + 1
        End If
    Next lien

End Sub

Sub PartantsParCourse()
Dim i%, sw As Worksheet

With Sheets("Feuil1")
    For i = 3 To .Range("E" & Rows.Count).End(xlUp).Row
        Set sw = Sheets.Add
        sw.Select
        Range("A2") = .Range("E" & i)
        Range("B2") = "/cheval/"
        OnYVa
    Next
End With

End Sub

Function pageHTML(site As String) As String
    With CreateObject("WINHTTP.WinHTTPRequest.5.1")
        .Open "GET", site, False
        .send
        pageHTML = .responseText
    End With
End Function

Quand je regarde toncode, ca me rappelle quand j'apprenais la guitare et je je regardais mes potes à coté qui jouaient de la guitare manouche. Ca me donnait envie de la reposer direct !!! ....

MERCIIIII

Bon, on continue ? ...

J'ai juste repris la macro car créer une page pour chaque course n'était pas top !

Option Explicit

Sub OnYVa()
Dim i%, sw As Worksheet

    ' effacement
    Range("A1").CurrentRegion.Offset(2, 0).ClearContents

    ' recherche des courses
    rechercheLiens Range("A2").Value, "/partants-pmu/", "xxx"

    ' recherche des chevaux
    Set sw = Sheets.Add
    sw.Select
    Range("A1") = "Chevaux"
    With Sheets("Feuil1")
        For i = 3 To .Range("A" & Rows.Count).End(xlUp).Row
            rechercheLiens .Range("A" & i).Value, "/cheval/", "-performance-"
        Next
    End With

End Sub

Sub rechercheLiens(site As String, parametre As String, sauf As String)
Dim lig%, page As New HTMLDocument, lien As Object, url As String

    ' création de l'objet page avec comme contenu le site
    page.body.innerHTML = pageHTML(site)

    ' recherche des liens contenant un mot-clé
    lig = Range("A" & Rows.Count).End(xlUp).Row + 1 ' 1ère ligne disponible
    For Each lien In page.getElementsByTagName("a")
        url = lien.getAttribute("href")
        If url Like "*" & parametre & "*" And Not url Like "*" & sauf & "*" Then
            Range("A" & lig) = Replace(url, "about:", "http://www.geny.com")
            lig = lig + 1
        End If
    Next lien

    ' suppression des doublons
    ActiveSheet.Range("$A$1:$A$" & lig).RemoveDuplicates Columns:=1, Header:=xlYes
    Columns("A:A").EntireColumn.AutoFit

End Sub

Function pageHTML(site As String) As String
    With CreateObject("WINHTTP.WinHTTPRequest.5.1")
        .Open "GET", site, False
        .send
        pageHTML = .responseText
    End With
End Function

Attention ... cela dure au moins une minute (et donc l'étape suivante sera de créer un indicateur d'avancement !)

65geny-etape-2.xlsm (207.39 Ko)

@Kesta ... on poursuit ?

Coucou,

oui oui !!! je regarde ça !!!

Mais juste pour faire une parenthèse sur mon code turfiste perso, j'essaie de faire un truc a priori simple sur un fichier pro et je bug complet.

Alors j'ouvre la parenthèse :

J'ai requeté plusieurs fichiers sur un seul tableur via power query. Ca s'actualise, les colonnes se rangent comme je veux etc. Par contre je souhaiterais remplir une colonne avec tous les articles qui concernent une famille voulue. sur un autre onglet. Donc je fais ça (bêtement) et rien ne se passe :

Sub Macro2()

'

' Macro2 Macro

'

Dim i As Integer

Dim j As Integer

Dim k As Integer

Dim article As Range

Dim famille As Range

Dim report_famille As Range

i = 1

j = 1

k = 4

Worksheets("base articles").Columns("b").Rows(i) = article

Worksheets("base articles").Columns("a").Rows(j) = famille

Worksheets("feuil1").Columns("a").Rows(k) = report_famille

Do

If famille = Worksheets("Feuil1").Range("AE1") Then

Range("article").Select.Copy

Range("report_famille").Select.Paste

i = i + 1

j = j + 1

k = k + 1

Loop Until articles = ""

End If

End Sub

NB : je regarde ton fichier geny de suite mais chutt....

je souhaiterais remplir une colonne avec tous les articles qui concernent une famille voulue. sur un autre onglet. Donc je fais ça (bêtement) et rien ne se passe ...

Je pense qu'un fichier serait nécessaire

Voici ce qui m'intrigue :

If famille = Worksheets("Feuil1").Range("AE1") Then

famille est égal à quoi avant d'en faire la comparaison avec la cllule AE1 de la Feuil1 ?

Puis je t'envoyer le fichier sur un mail ?

Worksheets("base articles").Columns("a").Rows(j) = famille

c'est pas bon ça?

hors sujet

hors sujet

hors sujet

hors sujet

Bref, tout ceci n'a plus rien à voir avec le sujet d'origine... j'ai donc effacé mes réponses pour ne pas nuire à la cohérence du post

Il faudrait en ouvrir un autre pour résoudre le sujet que tu évoques

Rechercher des sujets similaires à "import page web"