Recherche info sur page WEB via macro VB

**boubou26** · 03/04/2013, 16h53

Bonjour tous,
je suis nouveau sur le site ! et j'ai besoin d'aide quant a l'élaboration d'une macro sous excel qui me permettrai de faire des recherches sur un site web (societe.com) à partir d'un numéro siren. Je n'arrive pas a automatiser la maquette... aider moi svp !

ps : ci joint le début de mon fichier
ps 2 : l'info qu'il me faut se situe au niveau : décision de justice (lorsqu'il y en a une)

**pc75** · 04/04/2013, 09h36

Bonjour,

A quel endroit on voit "décision de justice" ?

**Denis la Malice** · 04/04/2013, 10h30

Bonjour,
je vois que tu as le début d'un commencement d'approche. Je te propose une autre méthode plus simple.
Quand tu analyses le code source de la page "www.societe.com" tu vois que le formulaire de recherche utilise la méthode GET avec un appel à "/cgi-bin/mainsrch/" et un paramètre "champ" qui contient le Siren débarrassé des espaces et autres caractères superflus. Seuls 9 chiffres sont autorisés.
L'URL a saisir est donc : http://www.societe.com/cgi-bin/mains...hamp=480753482 pour le siren "480 753 482" (qui correspond a un margoulin qui a 3 décisions de justice).

Je pense que saisir le Siren et le mettre en forme et le contrôler est facile.
Construire l'URL est également facile.

Maintenant, pour récupérer le contenu de la page, je te suggère la méthode suivante :

Cherche si tu as une feuille "Temp" et détruit-la si elle existe.
Crée une feuille "Temp"
Lance l'enregistreur de macro
Ajoute une liaison Web (Données --> A partir du Web)
Met l'URL définie ci-dessus.
Lance une recherche sur la chaine "Décision de justice"
Arrête l'enregistrement de la macro

Tu as alors tous les éléments pour construire ta macro.
Bon courage, il te reste encore un peu de boulot.

Tiens nous au courant de tes avancées et n'hésite pas à poser d'autres questions si tu ne t'en sors pas.

**pc75** · 04/04/2013, 10h48

Re,

La suite :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
 
    IE.Navigate "http://www.societe.com/societe/euro-builders-480753482.html"
    IE.Visible = True
 
    WaitIE IE
    contenu = IE.document.DocumentElement.innerText
    Debut = InStr(contenu, "Depuis")
    Fin = InStr(Debut, contenu, "Masquer")
    result = Mid(contenu, Debut, Fin - Debut)
    MsgBox result
    Set IE = Nothing
    Set IEDoc = Nothing

**boubou26** · 04/04/2013, 11h52

Bonjour à tous,
Merci pour votre début de réponse. Ce que tu me demande DENIS LA MALICE c'est du chinois pour moi... en faite je suis contrôleur de gestion avec quelques notion mais rien de bien concret pour faire ce genre d'outil.
Je comprend le raisonnement par contre je suis incapable de le faire.
Pourrais tu me dire comment faire ?

Merci par avance.

Cdt
boubou26

Bonjour Pc75,

Super ton code fonctionne ! le resultat s'affiche dans un userform.
Par contre si j'ai une liste comment faire pour qu'il me mette l'info en face de numero SIREN ?

Merci par avance pour ton aide.

Cdt
boubou26

**pc75** · 04/04/2013, 12h18

Re,

Envoyé par boubou26

Bonjour Pc75,

Super ton code fonctionne ! le resultat s'affiche dans un userform.
Par contre si j'ai une liste comment faire pour qu'il me mette l'info en face de numero SIREN ?

Merci par avance pour ton aide.

Cdt
boubou26

Tu peux préciser ta question, stp ?

**Denis la Malice** · 04/04/2013, 12h21

Bonjour,

utilise un code comme celui-ci pour mettre les résultats dans la deuxième colonne :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
Sub RemplirInfo()
    Dim Ligne As Integer
 
    Ligne = 2
    While Cells(Ligne, 1) <> ""
        Cells(Ligne, 2) = RechercheInfo(Cells(Ligne, 1))
        Ligne = Ligne + 1
    Wend
End Sub

Remplace ta procédure par une fonction en la déclarant comme ceci :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

Function RechercheInfo(Siren As String)

Modifie le code pour ne pas afficher le résultat mais le renvoyer :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
' Msgbox result
RechercheInfo = result

Améliore ta fonction de recherche de résultat pour prendre en compte les cas où il n'y a pas de décision de justice, par exemple.

**boubou26** · 04/04/2013, 12h24

Re,

Excuse moi pour mon manque d'explication.
En faite la liste de numéro siren se situe dans la colonne A (par exemple de la ligne 2 à 500).

Ce que j'aimerais est que en face du numéro SIREN c'est à dire dans la colonne B se reporte l'info que la "recherche" trouve (en gros ce que tu affiche dans le userform). Est ce possible ?

et on repete l'operation sur le nombre de numero SIREN existant dans la colonne A.

Restant à ton écoute.

boubou26

**pc75** · 04/04/2013, 12h49

Re,

Voilà :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
 
' Récupérer la dernière ligne
DerniereLigne = ActiveSheet.UsedRange.Rows.Count
 
' Boucler sur les lignes
For i = 2 To DerniereLigne
    Siren = ActiveSheet.Cells(i, 1).Value
    IE.Navigate "http://www.societe.com/societe/euro-builders-" & Siren & ".html"
    IE.Visible = True
 
    'WaitIE IE
    contenu = IE.document.DocumentElement.innerText
    Debut = InStr(contenu, "Depuis")
    ' Tester si il y a des décisions
    If Debut > 0 Then
        Fin = InStr(Debut, contenu, "Masquer")
        Result = Mid(contenu, Debut, Fin - Debut)
        ' Ecrire dans la colonne 2
        ActiveSheet.Cells(i, 2).Value = Result
    End If
Next
Set IE = Nothing
Set IEDoc = Nothing

**boubou26** · 04/04/2013, 13h05

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
Sub rechercheinfo()


Dim IE As New InternetExplorer
Dim IEDoc As HTMLDocument
Dim htmlTagCol As IHTMLElementCollection
Dim htmlSelectElem As HTMLSelectElement
Dim NbrEntree As Integer
Dim TableauValeur()
Dim TheEntree As Integer

   'Ouvre la page Web
     
   ' Récupérer la dernière ligne
DerniereLigne = ActiveSheet.UsedRange.Rows.Count
 
' Boucler sur les lignes
For i = 2 To DerniereLigne
    Siren = ActiveSheet.Cells(i, 1).Value
    IE.Navigate "http://www.societe.com/societe/euro-builders-" & Siren & ".html"
    IE.Visible = True
 
    'WaitIE IE
    contenu = IE.document.DocumentElement.innerText
    Debut = InStr(contenu, "Depuis")
    ' Tester si il y a des décisions
    If Debut > 0 Then
        Fin = InStr(Debut, contenu, "Masquer")
        Result = Mid(contenu, Debut, Fin - Debut)
        ' Ecrire dans la colonne 2
        ActiveSheet.Cells(i, 2).Value = Result
    End If
Next
Set IE = Nothing
Set IEDoc = Nothing

**pc75** · 04/04/2013, 13h08

Re,

Enlève le commentaire sur cette ligne :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
 
'WaitIE IE

**boubou26** · 04/04/2013, 13h12

re,
si je fais ce que tu me dis, il m'apparait un message "page404 introuvable"

**Denis la Malice** · 04/04/2013, 13h32

Bonjour,
bien que le code de PC75 soit en fait plus simple que ce que je proposais, voici le code avec ma fonction de recherche :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
Function RechercheInfo(Siren As String) As String
    Dim Feuille As Worksheet, Cellule As Range
 
    ' Valeur de retour par défaut
    RechercheInfo = "Je n'ai rien trouvé"
    ' Destruction de l'onglet "Temp" s'il existe
    For Each Feuille In ActiveWorkbook.Sheets
        If Feuille.Name = "Temp" Then
            Application.DisplayAlerts = False   ' Pour éviter le message de confirmation de destruction
            Sheets("Temp").Delete
            Application.DisplayAlerts = True
            Exit For
        End If
    Next Feuille
    ' Creation de la feuille temporaire
    Sheets.Add.Name = "Temp"
    Sheets("Feuil1").Activate
    ' Creation de la connexion Web
    With Sheets("Temp")
        With .QueryTables.Add(Connection:= _
            "URL;http://www.societe.com/cgi-bin/mainsrch/?champ=" & Siren, Destination _
            :=Sheets("Temp").Cells(1, 1))
            .Name = Siren
            .FieldNames = True
            .RowNumbers = False
            .FillAdjacentFormulas = False
            .PreserveFormatting = False
            .RefreshOnFileOpen = False
            .BackgroundQuery = False
            .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
 
        ' Recherche des décisions de justice
        Set Cellule = .Cells.Find(What:="Décision de justice", After:=.Cells(1, 1), LookIn:= _
            xlFormulas, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:= _
            xlNext, MatchCase:=False, SearchFormat:=False)
        If Cellule Is Nothing Then
            RechercheInfo = "Pas de décision de justice"
        Else
            RechercheInfo = Cellule.Value
        End If
        ' Recherche des entreprises radiées
        Set Cellule = .Cells.Find(What:="Entreprise radiée", After:=.Cells(1, 1), LookIn:= _
            xlFormulas, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:= _
            xlNext, MatchCase:=False, SearchFormat:=False)
        If Not Cellule Is Nothing Then
            RechercheInfo = RechercheInfo & " [" & Cellule.Value & "]"
        End If
 
        Set Cellule = Nothing
 
    End With
 
    Application.DisplayAlerts = False
    Sheets("Temp").Delete
    Application.DisplayAlerts = True
 
End Function

Il faut changer la macro affectée au bouton dans "Feuil1" pour pointer sur RemplirInfo
Élargis aussi un peu la colonne 2

Il faut utiliser l'URL suivante :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

"http://www.societe.com/cgi-bin/mainsrch/?champ=" & Siren

et non :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

"http://www.societe.com/societe/euro-builders-" & Siren & ".html"

Le site societe.com fait une redirection.

**pc75** · 04/04/2013, 14h38

Re,

Il y a une erreur javascript sur leur site, ce qui empêche le chargement complet de la page.

Et quand l'erreur javascript ne se produit pas, le temps de chargement complet de la page est extrêmement long. Le message "(1 élément(s) restant)) attente de http....." dans la barre de statut bloque la page

**boubou26** · 04/04/2013, 14h43

en prenant le code je ne trouve plus la macro !!
aide please....

**pc75** · 04/04/2013, 15h07

Re,

Regarde dans le Module1

**boubou26** · 04/04/2013, 15h11

merci de ta reponse
pourquoi le code n'apparait il pas avec un nom pour que je puisse le rattache a un bouton de macro?

**pc75** · 04/04/2013, 15h14

Parce qu'il est dans un module. Fais un copier/coller du code dans une macro.

PS : C'est quelle version d'Excel ?

**boubou26** · 04/04/2013, 15h19

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
Sub remplirinfo()
 
Function RechercheInfo(Siren As String) As String
    Dim Feuille As Worksheet, Cellule As Range
 
    ' Valeur de retour par défaut
    RechercheInfo = "Je n'ai rien trouvé"
    ' Destruction de l'onglet "Temp" s'il existe
    For Each Feuille In ActiveWorkbook.Sheets
        If Feuille.Name = "Temp" Then
            Application.DisplayAlerts = False   ' Pour éviter le message de confirmation de destruction
            Sheets("Temp").Delete
            Application.DisplayAlerts = True
            Exit For
        End If
    Next Feuille
    ' Creation de la feuille temporaire
    Sheets.Add.Name = "Temp"
    Sheets("Feuil1").Activate
    ' Creation de la connexion Web
    With Sheets("Temp")
        With .QueryTables.Add(Connection:= _
            "URL;http://www.societe.com/cgi-bin/mainsrch/?champ=" & Siren, Destination _
            :=Sheets("Temp").Cells(1, 1))
            .Name = Siren
            .FieldNames = True
            .RowNumbers = False
            .FillAdjacentFormulas = False
            .PreserveFormatting = False
            .RefreshOnFileOpen = False
            .BackgroundQuery = False
            .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
 
        ' Recherche des décisions de justice
        Set Cellule = .Cells.Find(What:="Décision de justice", After:=.Cells(1, 1), LookIn:= _
            xlFormulas, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:= _
            xlNext, MatchCase:=False, SearchFormat:=False)
        If Cellule Is Nothing Then
            RechercheInfo = "Pas de décision de justice"
        Else
            RechercheInfo = Cellule.Value
        End If
        ' Recherche des entreprises radiées
        Set Cellule = .Cells.Find(What:="Entreprise radiée", After:=.Cells(1, 1), LookIn:= _
            xlFormulas, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:= _
            xlNext, MatchCase:=False, SearchFormat:=False)
        If Not Cellule Is Nothing Then
            RechercheInfo = RechercheInfo & " [" & Cellule.Value & "]"
        End If
 
        Set Cellule = Nothing
 
    End With
 
    Application.DisplayAlerts = False
    Sheets("Temp").Delete
    Application.DisplayAlerts = True
 
 
End Function

je pense que je suis depassé !
est ce que c'est bien ca qu'il faut faire ?

**Denis la Malice** · 04/04/2013, 15h40

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
Sub RemplirInfo()
    Dim Ligne As Integer
 
    Ligne = 2
    While Cells(Ligne, 1) <> ""
        Cells(Ligne, 2) = RechercheInfo(Cells(Ligne, 1))
        Ligne = Ligne + 1
    Wend
End Sub
 
Function RechercheInfo(Siren As String) As String
    Dim Feuille As Worksheet, Cellule As Range
 
    ' Valeur de retour par défaut
    RechercheInfo = "Je n'ai rien trouvé"
    ' Destruction de l'onglet "Temp" s'il existe
    For Each Feuille In ActiveWorkbook.Sheets
        If Feuille.Name = "Temp" Then
            Application.DisplayAlerts = False   ' Pour éviter le message de confirmation de destruction
            Sheets("Temp").Delete
            Application.DisplayAlerts = True
            Exit For
        End If
    Next Feuille
    ' Creation de la feuille temporaire
    Sheets.Add.Name = "Temp"
    Sheets("Feuil1").Activate
    ' Creation de la connexion Web
    With Sheets("Temp")
        With .QueryTables.Add(Connection:= _
            "URL;http://www.societe.com/cgi-bin/mainsrch/?champ=" & Siren, Destination _
            :=Sheets("Temp").Cells(1, 1))
            .Name = Siren
            .FieldNames = True
            .RowNumbers = False
            .FillAdjacentFormulas = False
            .PreserveFormatting = False
            .RefreshOnFileOpen = False
            .BackgroundQuery = False
            .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
 
        ' Recherche des décisions de justice
        Set Cellule = .Cells.Find(What:="Décision de justice", After:=.Cells(1, 1), LookIn:= _
            xlFormulas, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:= _
            xlNext, MatchCase:=False, SearchFormat:=False)
        If Cellule Is Nothing Then
            RechercheInfo = "Pas de décision de justice"
        Else
            RechercheInfo = Cellule.Value
        End If
        ' Recherche des entreprises radiées
        Set Cellule = .Cells.Find(What:="Entreprise radiée", After:=.Cells(1, 1), LookIn:= _
            xlFormulas, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:= _
            xlNext, MatchCase:=False, SearchFormat:=False)
        If Not Cellule Is Nothing Then
            RechercheInfo = RechercheInfo & " [" & Cellule.Value & "]"
        End If
 
        Set Cellule = Nothing
 
    End With
 
    Application.DisplayAlerts = False
    Sheets("Temp").Delete
    Application.DisplayAlerts = True
 
End Function

Recherche info sur page WEB via macro VB

Macros et VBA Excel

Discussions similaires

Partager

Partager