Récupérer automatiquement les SIREN de vos clients
LA réforme de la facturation électronique aoblige à avoir les SIREN de ces clients et parfois c’est galère.
Voici un tuto tout simple pour le faire (sous excel)
Pour tous ceux qui galère à chercher/saisir les SIREN dans leur BDD en vue de la réforme de la facturation électronique 👇
1.Extraire dans excel vos données (au moins les RS + pays + code postal et un identifiant pour les remettre à jour dans l'outil d'origine).
2. Activer l'onglet Développeur (clic droit sur la barre de menus en haut/
Personnaliser le ruban/colonne de droite, cochez la case Développeur/OK
3. Nouvel onglet Développeur./Cliquez sur Visual Basic (tout à gauche).
4.Copiez le code ci-dessous et collez-le dans la page blanche. Modifiez les numéros des colonnes.
Appuyez sur la touche F5 de votre clavier ou cliquez sur l'icône "Play"(flèche verte) pour l'exécuter.
ça vous fera déjà 3/4 du boulot.
Bon courage ;-)
Sub ExtraireSirenPro()
' --- CONFIGURATION ---
Const col_RS As Integer = 2 ' Colonne de la raison sociale?
Const col_CP As Integer = 3 ' Colonne du code postal?
Const col_SIREN As Integer = 7 ' Colonne où sera inscit le SIREN?
Const LIGNE_DEPART As Integer = 2 (1ère ligne contenant des données à traiter)
' ---------------------
Dim i As Long, dernierLigne As Long
Dim raisonNettoyee As String, cpNettoye As String
Dim status As Integer, url As String
Dim http As Object
Set http = CreateObject("MSXML2.XMLHTTP")
dernierLigne = Cells(Rows.count, col_RS).End(xlUp).Row
For i = LIGNE_DEPART To dernierLigne
' On ne traite que si la case SIREN est vide pour gagner du temps
If Cells(i, col_SIREN).Value = "" And Cells(i, col_RS).Value <> "" And Cells(i, 15) = "F" Then
' --- PREPARATION & ENCODAGE ---
' EncodeURL gère les accents, les & et les espaces pour l'API
raisonNettoyee = Application.EncodeURL(Cells(i, col_RS).Value)
' On s'assure que le CP ne contient pas d'espaces parasites
cpNettoye = Trim(Replace(Cells(i, col_CP).Value, " ", ""))
url = "https://recherche-entreprises.api.gouv.fr/search?q=" & raisonNettoyee & "&code_postal=" & cpNettoye & "&per_page=1"
Application.StatusBar = "Ligne " & i & "/" & dernierLigne & " : " & Cells(i, col_RS).Value
Do
http.Open "GET", url, False
http.Send
status = http.status
If status = 429 Then ' Quota dépassé
Application.StatusBar = "!! QUOTA ATTEINT !! Attente de 2 min..."
Application.Wait (Now + TimeValue("00:02:00"))
ElseIf status = 200 Then
Cells(i, col_SIREN).Value = ExtraireSirenDepuisJSON(http.ResponseText)
ElseIf status = 400 Then
Cells(i, col_SIREN).Value = "Erreur 400 : Requête malformée"
Else
Cells(i, col_SIREN).Value = "Erreur " & status
End If
DoEvents
Loop While status = 429
' Pause de sécurité (5 requêtes/sec pour rester sous la limite de 7)
Application.Wait (Now + TimeSerial(0, 0, 1) / 5)
End If
Next i
Application.StatusBar = False
MsgBox "Extraction terminée !", vbInformation
End Sub
Function ExtraireSirenDepuisJSON(json As String) As String
Dim pos As Long
pos = InStr(json, """siren"":""")
If pos > 0 Then
ExtraireSirenDepuisJSON = Mid(json, pos + 9, 9)
Else
ExtraireSirenDepuisJSON = "Non trouvé"
End If
End Function
Sub ExtraireSirenPro()
' --- CONFIGURATION ---
Const col_RS As Integer = 2 ' Colonne de la raison sociale?
Const col_CP As Integer = 3 ' Colonne du code postal?
Const col_SIREN As Integer = 7 ' Colonne où sera inscit le SIREN?
Const LIGNE_DEPART As Integer = 2 (1ère ligne contenant des données à traiter)
' ---------------------
Dim i As Long, dernierLigne As Long
Dim raisonNettoyee As String, cpNettoye As String
Dim status As Integer, url As String
Dim http As Object
Set http = CreateObject("MSXML2.XMLHTTP")
dernierLigne = Cells(Rows.count, col_RS).End(xlUp).Row
For i = LIGNE_DEPART To dernierLigne
' On ne traite que si la case SIREN est vide pour gagner du temps
If Cells(i, col_SIREN).Value = "" And Cells(i, col_RS).Value <> "" And Cells(i, 15) = "F" Then
' --- PREPARATION & ENCODAGE ---
' EncodeURL gère les accents, les & et les espaces pour l'API
raisonNettoyee = Application.EncodeURL(Cells(i, col_RS).Value)
' On s'assure que le CP ne contient pas d'espaces parasites
cpNettoye = Trim(Replace(Cells(i, col_CP).Value, " ", ""))
url = "https://recherche-entreprises.api.gouv.fr/search?q=" & raisonNettoyee & "&code_postal=" & cpNettoye & "&per_page=1"
Application.StatusBar = "Ligne " & i & "/" & dernierLigne & " : " & Cells(i, col_RS).Value
Do
http.Open "GET", url, False
http.Send
status = http.status
If status = 429 Then ' Quota dépassé
Application.StatusBar = "!! QUOTA ATTEINT !! Attente de 2 min..."
Application.Wait (Now + TimeValue("00:02:00"))
ElseIf status = 200 Then
Cells(i, col_SIREN).Value = ExtraireSirenDepuisJSON(http.ResponseText)
ElseIf status = 400 Then
Cells(i, col_SIREN).Value = "Erreur 400 : Requête malformée"
Else
Cells(i, col_SIREN).Value = "Erreur " & status
End If
DoEvents
Loop While status = 429
' Pause de sécurité (5 requêtes/sec pour rester sous la limite de 7)
Application.Wait (Now + TimeSerial(0, 0, 1) / 5)
End If
Next i
Application.StatusBar = False
MsgBox "Extraction terminée !", vbInformation
End Sub
Function ExtraireSirenDepuisJSON(json As String) As String
Dim pos As Long
pos = InStr(json, """siren"":""")
If pos > 0 Then
ExtraireSirenDepuisJSON = Mid(json, pos + 9, 9)
Else
ExtraireSirenDepuisJSON = "Non trouvé"
End If
End Function
