Recherche info sur page WEB via macro VB

Version imprimable

Voir 40 message(s) de cette discussion en une page

03/04/2013, 15h53
boubou26

1 pièce(s) jointe(s)

Recherche info sur page WEB via macro VB

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)
04/04/2013, 08h36
pc75

Bonjour,

A quel endroit on voit "décision de justice" ?
04/04/2013, 09h30
Denis la Malice

Une approche simple
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. :ccool:

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

Re,

La suite :

Code:

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

04/04/2013, 10h52
boubou26

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
04/04/2013, 11h18
pc75

Re,

Citation:

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 ?
04/04/2013, 11h21
Denis la Malice

Automatisation
Bonjour,

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

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:

Function RechercheInfo(Siren As String)

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

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.
04/04/2013, 11h24
boubou26

Re aide

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

Re,

Voilà :

Code:

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

Re aide debogage sur la ligne en gras

Code:

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

04/04/2013, 12h08
pc75
Re,

Enlève le commentaire sur cette ligne :
Code:

1 2 'WaitIE IE
04/04/2013, 12h12
boubou26

Re aide

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

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:

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:

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

et non :

Code:

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

Le site societe.com fait une redirection.

04/04/2013, 13h38
pc75

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
04/04/2013, 13h43
boubou26

1 pièce(s) jointe(s)

Re aide

en prenant le code je ne trouve plus la macro !!
aide please....
04/04/2013, 14h07
pc75

Re,

Regarde dans le Module1
04/04/2013, 14h11
boubou26

Re aide

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?
04/04/2013, 14h14
pc75

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

PS : C'est quelle version d'Excel ?

Code:

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 ?

Le code complet

Code:

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

Voir 40 message(s) de cette discussion en une page