Extraction depuis site web

[chris1234]

Bonjour le forum,

Dans le cadre de mon travail je dois créer un bdd de mairies
J'ai donc créé une matrice pour extraire les données - matrice en PJ.

Je rencontre deux problèmes :
- comment ajouter un saut de ligne entre chaque ensemble de données (entre chaque url) ?
- la matrice s’arrête tte seul au bout de 5 url trouvés alors qu'il y en a 11 à trouver ?

Des idées ?
Merci de votre aide
Chris.

 

[camarchepas]

Re : Extraction depuis site web

Bonsoir Chris

Voici avec un petit nettoyage du code

 

[chris1234]

Re : Extraction depuis site web

Bonjour Camarchepas,
Merci de ton aide.
Le code fonctionne mais les résultats sont dupliqués plusieurs fois apparemment.
J'ai trouvé une autre solution en retour.
Merci encore!

Public i As Integer, compteur As Long

Sub lance_requête()
'Macro enregistré par MJ
Sheets("URL").Select
    Range("A1").Select
derligne = ActiveSheet.Range("A65536").End(xlUp).Row
compteur = 0
For i = 1 To derligne
req_web
Sheets("URL").Select
ActiveCell.Offset(1, 0).Range("A1").Select
Next i
'efface la requête à la fin
Sheets("Requête").Select
 Range("A1").Select
 Cells.Select
    Selection.Delete Shift:=xlUp
   Range("A1").Select
   Sheets("Données").Select
End Sub
Sub req_web()
'Macro enregistré par MJ
'Dim i As Integer
Dim Chaine As String
'For i = 1 To 20
    'ActiveWorkbook.Worksheets.Add
'Stop
    'Chaine = "URL;" & Worksheets("URL").Cells(1, 1).Value
    Chaine = ActiveCell.Value
    Sheets("Requête").Select
    Cells.ClearContents
    With ActiveSheet.QueryTables.Add(Connection:="URL;" & Chaine, _
    Destination:=Range("A1"))
        
        .Name = "mairie-14237-01"
        .FieldNames = True
        .RowNumbers = False
        .FillAdjacentFormulas = False
        .PreserveFormatting = True
        .RefreshOnFileOpen = False
        .BackgroundQuery = True
        .RefreshStyle = xlInsertDeleteCells
        .SavePassword = False
        .SaveData = True
        .AdjustColumnWidth = True
        .RefreshPeriod = 0
        .WebSelectionType = xlEntirePage
        .WebFormatting = xlWebFormattingNone
        .WebPreFormattedTextToColumns = True
        .WebConsecutiveDelimitersAsOne = True
        .WebSingleBlockTextImport = False
        .WebDisableDateRecognition = False
        .WebDisableRedirections = False
        .Refresh BackgroundQuery:=False
    End With
    
    If compteur <> 0 Then compteur = compteur + 1
    
    For ligne = 1 To 1000
        
        If Left(Sheets("Requête").Cells(ligne, 1), 5) = "Faire" Then
            compteur = compteur + 1
            Sheets("Données").Cells(compteur, 1) = Sheets("Requête").Cells(ligne - 2, 1)
        End If
    
        If Left(Sheets("Requête").Cells(ligne, 1), 16) = "Aller au contenu" Then
            compteur = compteur + 1
            Sheets("Données").Cells(compteur, 1) = Sheets("Requête").Cells(ligne - 2, 1)
        End If
        
        If Left(Sheets("Requête").Cells(ligne, 1), 24) = "Afficher le plan d'accès" Then
            compteur = compteur + 1
            Sheets("Données").Cells(compteur, 1) = Sheets("Requête").Cells(ligne - 2, 1)
        End If
        
        If Left(Sheets("Requête").Cells(ligne, 1), 24) = "Afficher le plan d'accès" Then
            compteur = compteur + 1
            Sheets("Données").Cells(compteur, 1) = Sheets("Requête").Cells(ligne - 3, 1)
        End If
        
        If Left(Sheets("Requête").Cells(ligne, 1), 9) = "Téléphone" Then
            compteur = compteur + 1
            Sheets("Données").Cells(compteur, 1) = Sheets("Requête").Cells(ligne + 2, 1)
        End If
        
    Next
    
End Sub