Recherche info sur page WEB via macro VB

Version imprimable

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

04/04/2013, 14h44
boubou26

Re aide

bien un GRAND MERCI !!
ca fonctionne bien ! encore merci !
19/07/2013, 14h22
boubou26

1 pièce(s) jointe(s)

Code VBA recuperant zone dans site web

Bonjour tous,

Je reviens vers vous car j'ai besoin de votre aide !
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 "activité"

Merci a tous pour votre aide.

cordialement
boubou26
19/07/2013, 15h10
Marc-L

Bonjour,

ton code a l'air de bien fonctionner, c'est peut-être qu'il n'y a pas de renseignement sur la page source …

Dans le doute, refaire la QueryTable manuellement sur un classeur vierge
pour vérifier exactement quelle cellule contient l'information …

__________________________________________________________________________________________

Merci de cliquer sur :plusser: pour chaque message ayant aidé puis sur :resolu: pour clore cette discussion …

Récupérer le type d'activité

Bonjour,
suite à une demande en MP, voici le code modifié pour récupérer le secteur d'activité des entreprises.

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
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
Sub RemplirInfo()
    Dim Ligne As Integer
 
    Ligne = 2
    While Cells(Ligne, 1) <> ""
        Cells(Ligne, 2) = "..."
        DoEvents
        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 (ça ne sert à rien, mais j'ai appris qu'il fallait toujours initialiser ses variables).
    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
        ' Vérification de l'existance d'une réponse
        Set Cellule = .Cells.Find(What:="Pas de réponse pour ce RNCS. ", After:=.Cells(1, 1), LookIn:= _
            xlFormulas, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:= _
            xlNext, MatchCase:=False, SearchFormat:=False)
        If Cellule Is Nothing Then
            ' OK, le Siren existe
        Else
            RechercheInfo = "Le numéro Siren n'existe pas."
            Exit Function
        End If
 
        ' 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
        ' Recherche de l'activité
        ' ATTENTION la recherche porte sur la totalité de la cellule (LookAt:=xlWhole) pour ne pas être
        ' perturbé par toutes les cellule qui contiennent le mot "actvité".
        Set Cellule = .Cells.Find(What:="Activité", After:=.Cells(1, 1), LookIn:= _
            xlFormulas, LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:= _
            xlNext, MatchCase:=False, SearchFormat:=False)
        If Not Cellule Is Nothing Then
            RechercheInfo = RechercheInfo & " APE= " & Cellule.Offset(1, 5).Value & " (" & Cellule.Offset(0, 5).Value & ")"
        End If
 
        Set Cellule = Nothing
 
    End With
 
    Application.DisplayAlerts = False
    Sheets("Temp").Delete
    Application.DisplayAlerts = True
 
End Function

21/07/2013, 19h03
Marc-L

Bonjour Denis,

en fait un sujet doublon a été ouvert entre temps : Code VBA recuperant zone dans site web …

A une fin pédagogique, objectif de ce forum, je l'aurais plutôt guidé afin de corriger
ses deux boulettes des lignes n°58 et 64 (du code d'origine du lien précédent)
au lieu de faire faire directement son boulot par d'autres, ce qui n'a pas lieu d'être sur ce forum ‼ …
21/07/2013, 19h03
Marc-L

La QueryTable fonctionne effectivement bien …

J'allais te demander de publier ton code afin de t'expliquer les deux grosses boulettes des lignes n°58 & 64
(pédagogique pour toi et d'autres afin de vous guider vers l'autonomie)
lorsque j'ai compris que ce sujet était en fait un doublon et qu'y plus est tu as fait une demande en MP dans ton sujet d'origine :

Recherche info sur page WEB via macro VB …

Pas la peine donc de publier ma solution tenant en 35 lignes de code …

Mise à jour du code

Bonjour,
le site Web de societe.com a évolué. Le code pour l'interroger aussi.

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
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
Sub RemplirInfo()
    Dim Ligne As Integer
 
    Ligne = 2
    While Cells(Ligne, 1) <> ""
        Cells(Ligne, 2) = "..."
        Cells(Ligne, 2) = RechercheInfo(Cells(Ligne, 1))
        DoEvents
        Ligne = Ligne + 1
 
    Wend
    Columns.EntireColumn.AutoFit
End Sub
 
Function RechercheInfo(Siren As String) As String
        Dim Feuille As Worksheet, Cellule As Range, Erreur As Long, Description As String
 
        Siren = Replace(Siren, " ", "")
        Siren = Replace(Siren, Chr(160), "")
 
        ' Valeur de retour par défaut (ça ne sert à rien, mais j'ai appris qu'il fallait toujours initialiser ses variables).
        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("SIREN").Activate
        ' Creation de la connexion Web
     With Sheets("Temp")
 
     ' Maintenant le site renvoie une erreur 404 si le SIERN n'existe pas. Ce qui génère une erreur et "plante" la macro.
     On Error Resume Next
 
          With .QueryTables.Add(Connection:= _
               "URL;http://www.societe.com/cgi-bin/fiche/?rncs=" & 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
 
          ' Il faut récupérer le contenu de Err avant de faire le "On Error Goto 0" qui réinitiallise Err.
          Erreur = Err.Number
          Description = Err.Description
 
          On Error GoTo 0
 
          ' Vérification de l'existance d'une réponse
          If Erreur = 0 Then
               ' Pas d'erreur en interrogeant le site
          ElseIf Erreur = 1004 Then
               RechercheInfo = "Le numéro Siren n'existe pas."
               Exit Function
          Else
               RechercheInfo = "Erreur d'interrogation du site."
               Exit Function
          End If
 
        ' Recherche des décisions de justice
        ' ATTENTION la recherche porte sur la totalité de la cellule (LookAt:=xlWhole) pour ne pas être
        ' perturbé par toutes les cellule qui contiennent le mot "jugement".
        Set Cellule = .Cells.Find(What:="Jugement", After:=.Cells(1, 1), LookIn:= _
            xlFormulas, LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:= _
            xlNext, MatchCase:=False, SearchFormat:=False)
        If Cellule Is Nothing Then
            RechercheInfo = "(Pas de décision de justice) -"
        Else
            RechercheInfo = Cellule.Offset(0, 1).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
        ' Recherche de l'activité
        Set Cellule = .Cells.Find(What:="Activité (Code NAF ou APE)", After:=.Cells(1, 1), LookIn:= _
            xlFormulas, LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:= _
            xlNext, MatchCase:=False, SearchFormat:=False)
        If Not Cellule Is Nothing Then
            RechercheInfo = RechercheInfo & " Activité = " & Cellule.Offset(0, 1).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