Re : Recherche Tél pour SIREN sur Internet
bonjour
tu peux t'inspirer peut-être du code suivant que j'avais fait pour un usage personnel.
au sein de la 1° macro, tu devras définir la base du lien hypertexte de la requête "http://totoworld.com/siren?=&" toncodesiren
la "macro_essai_parsing" est à réécrire entièrement ou partiellement, je te l'ai laissé à titre d'exemple pour correspondre à tes besoins.
ce code fonctionne ainsi : définis dans la 1° macro l'URL de base, place toi dans une feuille, sélectionnes-y les cellules contenant les siren, et lance la 1° macro.
elle crée les feuilles Reporting & Resultat si inexistantes
Dim ChainesAControler(1 To 49)
Sub macro_essai()
'On Error Resume Next
Application.ScreenUpdating = False
Dim fichier$ 'fichier en cours de lecture
Dim Pattern$ 'chaîne des fichiers à rechercher
Dim i% 'index du fichier en cours de lecture
Dim wbActif As Workbook 'pour que la macro écrive dans le classeur en cours
Dim wshResultSheet As Worksheet 'et dans la feuille en cours
Dim wshQuerySheet As Worksheet 'feuille de travail créée à chaque exécution de la macro
Dim objQT As QueryTable 'une requête sera effectuée pour importer chaque fichier dans la feuille d'analyse
Dim Range_Siren As Range 'contient les codes siren
Dim Requete_URL_Base As String
Range_Siren = Selection
Requete_URL_Base = "http://www.........?&..."
Set wbActif = ActiveWorkbook
If SheetExist("Reporting") = False Then
wbActif.Worksheets.Add
ActiveSheet.Name = "Reporting" '& Format(Now, "yyymmdd_hmm")
End If
Set wshResultSheet = wbActif.Worksheets("Reporting")
wshResultSheet.Cells.Clear
'la liste des colonnes est stockée dans une variables tableau "ChainesAControler"
Call init_tableau
For i = 1 To UBound(ChainesAControler)
wshResultSheet.Cells(1, i).Value = ChainesAControler(i)
Next i
'la feuille crée ci-dessous est crée à chaque lancement de macro
'et c'est dans cette feuille qu'est rapatrié le résultat des requêtes web
If SheetExist("Requete_Web") = False Then
wbActif.Worksheets.Add
ActiveSheet.Name = "Requete_Web" '& Format(Now, "yyymmdd_hmm")
End If
Set wshQuerySheet = wbActif.Worksheets("Requete_Web")
For Each cl In Range_Siren
i = i + 1
'Création de la requête pour récupérer les données.
With wshQuerySheet
If objQT Is Nothing Then
Set objQT = .QueryTables.Add(Connection:="URL;" & Requete_URL_Base & cl.Value, Destination:=.Range("A1"))
objQT.Refresh
Else
With objQT
If .Refreshing Then
Debug.Print "Query is currently refreshing: please wait"
Else
.Connection = "URL;" & strTargetDir & fichier: .Refresh ' BackgroundQuery:=False' .ResultRange.Select
End If
End With
End If
End With
'Analyse de la page requêtée
Call macro_essai_parsing(wshQuerySheet, wshResultSheet)
'passage au fichier suivant
fichier = Dir
Next cl
Exit Sub
handler:
On Error GoTo 0
End Sub
Sub macro_essai_parsing(wshQuerySheet, wshResultSheet)
Application.ScreenUpdating = False
Dim ControleFicheArticle As Range, rg_caracteristique As Range, caracteristique, val_caracteristique
Dim actRow As Long, k As Long
actRow = wshResultSheet.Range("A65536").End(xlUp).Row
If actRow = 1 Then actRow = 2 Else actRow = actRow + 1
'en supposant que la requête web a échoué et que la page retournée n'est pas la page escomptée
'il faut prévoir un contrôle pour passer à la requête suivante et donc sortir de cette procédure.
'ici, le mot à rechercher est la première valeur de la variable tableau ChainesAControler(1)
'adaptez et réactiver si vous voulez vous en servir
'Set ControleFicheArticle = wshResultSheet.Cells.Find(what:=ChainesAControler(1))
'If ControleFicheArticle Is Nothing Then GoTo nnext
X = 0
Do
'nous partons d'une cellule et descendons faire le bas
Set cl = wshQuerySheet.Range("D13").Offset(X)
If cl.Address(0, 0) = "D13" Then k = 1: val_caracteristique = cl.Value: GoTo wwrite
If cl.Address(0, 0) = "D14" Then k = 2: val_caracteristique = cl.Value: GoTo wwrite
If UBound(Split(cl.Value, ":")) <> -1 Then
'recherche index colonne
If UBound(Split(cl.Value, ":")) > 0 Then
caracteristique = Split(cl.Value, ":")(0)
Set rg_caracteristique = wshResultSheet.Rows(1).Find(what:=Trim(caracteristique))
If Not rg_caracteristique Is Nothing Then
k = rg_caracteristique.Column
Else
k = wshResultSheet.Rows(1).End(xlToRight).Column + 1
wshResultSheet.Cells(1, k).Value = caracteristique
End If
val_caracteristique = Split(cl.Value, ":")(1)
End If
End If
wwrite:
If cl.Value <> "" Then wshResultSheet.Cells(actRow, k).Value = val_caracteristique
X = X + 1
Loop Until cl.Value = "" & cl.Row <= wshQuerySheet.Range("D65536").End(xlUp).Row
nnext:
End Sub
Sub init_tableau()
ChainesAControler(1) = "N°"
ChainesAControler(2) = "Raison sociale"
ChainesAControler(3) = "Siren"
ChainesAControler(4) = "APE Naf700"
ChainesAControler(5) = "Intitulé Naf"
ChainesAControler(6) = "APE Nes114S"
ChainesAControler(7) = "Intitulé Nes"
ChainesAControler(8) = "Code postal"
ChainesAControler(9) = "Commune"
ChainesAControler(10) = "Dept"
ChainesAControler(11) = "Region"
ChainesAControler(12) = "de pax"
ChainesAControler(13) = "à pax"
ChainesAControler(14) = "CA 2006 de"
ChainesAControler(15) = "à CA 2006"
ChainesAControler(16) = "Tranche de taux d'export"
End Sub
Public Function SheetExist(Sheet As String) As Boolean
On Error GoTo FExErr
Worksheets(Sheet).Select
SheetExist = True
Exit Function
FExErr: SheetExist = False
Exit Function
End Function
