Macro Excel pour vérifier instantanément le statut des entreprises françaises

=CheckCompanyStatus(B2;D2;C2)

Function CheckCompanyStatus(companyName As String, postalCode As String, Optional address As String = "") As String
Dim http As Object, url As String, response As String
Dim companyStatus As String, dateFermeture As String, etabsOuverts As String
Dim matchingAdress As Boolean, newAddress As String, sirenValue As String
Dim formattedAddress As String' Créer l'objet HTTP
Set http = CreateObject("MSXML2.XMLHTTP")' Construire l'URL de l'API
url = "https://recherche-entreprises.api.gouv.fr/search?q=" & _
WorksheetFunction.EncodeURL(companyName) & _
"&code_postal=" & postalCode & _
"&per_page=1"' Exécuter la requête API
On Error Resume Next
http.Open "GET", url, False
http.send
On Error GoTo 0' Vérifier si la requête a réussi
If http.status = 200 Then
response = http.responseText

' Extraction des informations de base
companyStatus = ExtractValue(response, """etat_administratif"":""", """")
sirenValue = ExtractValue(response, """siren"":""", """")
etabsOuverts = ExtractValue(response, """nombre_etablissements_ouverts"":", ",")
Dim totalEtabs As String
totalEtabs = ExtractValue(response, """nombre_etablissements"":", ",")

' Vérifier si l'établissement spécifique est ouvert ou fermé
Dim matchingEstablishment As String
matchingEstablishment = ExtractBetween(response, """matching_etablissements"":[", "]")

If matchingEstablishment <> "" Then
' Vérifier si l'établissement correspondant est fermé
Dim matchingStatus As String, matchingDateFermeture As String
matchingStatus = ExtractValue(matchingEstablishment, """etat_administratif"":""", """")
matchingDateFermeture = ExtractValue(matchingEstablishment, """date_fermeture"":""", """")

' Information sur l'adresse
Dim matchingAdresseComplete As String
matchingAdresseComplete = ExtractValue(matchingEstablishment, """adresse"":""", """")

' Vérifier le statut de l'établissement
If matchingStatus = "F" Or matchingDateFermeture <> "" And matchingDateFermeture <> "null" Then
' L'établissement est fermé, mais l'entreprise peut être active
If companyStatus = "A" Then
' Récupérer l'adresse du siège
Dim siegeInfo As String, siegeAdresse As String, siegeCP As String, siegeVille As String
siegeInfo = ExtractBetween(response, """siege"":{", "},")
siegeAdresse = ExtractValue(siegeInfo, """adresse"":""", """")
siegeCP = ExtractValue(siegeInfo, """code_postal"":""", """")
siegeVille = ExtractValue(siegeInfo, """libelle_commune"":""", """")

' Format de retour détaillé
CheckCompanyStatus = "ENTREPRISE ACTIVE mais ETABLISSEMENT FERMÉ" & vbCrLf & _
"Date fermeture: " & matchingDateFermeture & vbCrLf & _
"Adresse siège: " & siegeAdresse & vbCrLf & _
"SIREN: " & sirenValue & vbCrLf & _
"Etablissements ouverts: " & etabsOuverts & "/" & totalEtabs
Else
' L'entreprise est aussi fermée
CheckCompanyStatus = "ENTREPRISE FERMÉE" & vbCrLf & _
"Date fermeture: " & matchingDateFermeture & vbCrLf & _
"SIREN: " & sirenValue
End If
Else
' L'établissement est ouvert (normalement ne devrait pas arriver dans matching si l'adresse est la même)
CheckCompanyStatus = "ACTIF" & vbCrLf & _
"SIREN: " & sirenValue & vbCrLf & _
"Etablissements ouverts: " & etabsOuverts & "/" & totalEtabs
End If
Else
' Pas d'établissement correspondant à cette adresse, mais vérifier le siège
Dim siegeSection As String
siegeSection = ExtractBetween(response, """siege"":{", "},")

If siegeSection <> "" Then
Dim siegeStatus As String, siegeDateFermeture As String, siegeAdress As String
siegeStatus = ExtractValue(siegeSection, """etat_administratif"":""", """")
siegeDateFermeture = ExtractValue(siegeSection, """date_fermeture"":""", """")
siegeAdress = ExtractValue(siegeSection, """adresse"":""", """")

' Décider du statut global
If companyStatus = "A" Then
CheckCompanyStatus = "ENTREPRISE ACTIVE" & vbCrLf & _
"Adresse siège: " & siegeAdress & vbCrLf & _
"SIREN: " & sirenValue & vbCrLf & _
"Etablissements ouverts: " & etabsOuverts & "/" & totalEtabs
Else
CheckCompanyStatus = "ENTREPRISE FERMÉE" & vbCrLf & _
"SIREN: " & sirenValue
End If
Else
' Aucune information de siège disponible
CheckCompanyStatus = "STATUT INDÉTERMINÉ (informations partielles)"
End If
End If
Else
' Erreur API
CheckCompanyStatus = "ERREUR API: " & http.status
End If
End Function

' Fonction pour extraire une valeur entre deux marqueurs
Function ExtractValue(jsonText As String, startTag As String, endTag As String) As String
Dim startPos As Long, endPos As Long

startPos = InStr(jsonText, startTag)
If startPos > 0 Then
startPos = startPos + Len(startTag)
endPos = InStr(startPos, jsonText, endTag)
If endPos > startPos Then
ExtractValue = Mid(jsonText, startPos, endPos – startPos)
Else
ExtractValue = ""
End If
Else
ExtractValue = ""
End If
End Function

' Fonction pour extraire une section complète entre deux marqueurs
Function ExtractBetween(jsonText As String, startTag As String, endTag As String) As String
Dim startPos As Long, endPos As Long, nestedCount As Long
Dim i As Long, char As String

startPos = InStr(jsonText, startTag)
If startPos > 0 Then
startPos = startPos + Len(startTag)

' Gestion des accolades/crochets imbriqués
If Right(startTag, 1) = "[" Then
nestedCount = 1
endPos = startPos

For i = startPos To Len(jsonText)
char = Mid(jsonText, i, 1)
If char = "[" Then
nestedCount = nestedCount + 1
ElseIf char = "]" Then
nestedCount = nestedCount – 1
If nestedCount = 0 Then
endPos = i – 1
Exit For
End If
End If
Next i

If endPos > startPos Then
ExtractBetween = Mid(jsonText, startPos, endPos – startPos)
Else
ExtractBetween = ""
End If
Else
' Méthode simple pour les sections sans imbrication
endPos = InStr(startPos, jsonText, endTag)
If endPos > startPos Then
ExtractBetween = Mid(jsonText, startPos, endPos – startPos)
Else
ExtractBetween = ""
End If
End If
Else
ExtractBetween = ""
End If
End Function

' Fonction pour ajouter à Excel
Sub ImplementCompanyStatusChecker()
Dim ws As Worksheet
Dim lastRow As Long, i As Long
Dim companyName As String, postalCode As String, address As String
Dim result As String

' Définir la feuille active
Set ws = ActiveSheet

' Vérifier que les colonnes nécessaires existent
If ws.Cells(1, 2).Value <> "Société" Then
MsgBox "La colonne B doit contenir le nom de la société (Société)", vbExclamation
Exit Sub
End If

If ws.Cells(1, 4).Value <> "cp" Then
MsgBox "La colonne D doit contenir le code postal (cp)", vbExclamation
Exit Sub
End If

' S'assurer que la colonne statut existe
If ws.Cells(1, 6).Value <> "Statut" Then
ws.Cells(1, 6).Value = "Statut"
End If

' Trouver la dernière ligne
lastRow = ws.Cells(ws.Rows.Count, 2).End(xlUp).Row

' Activer la barre de statut
Application.DisplayStatusBar = True
Application.StatusBar = "Initialisation…"
Application.ScreenUpdating = False

' Parcourir chaque ligne
For i = 2 To lastRow
' Mettre à jour la barre de progression
Application.StatusBar = "Traitement: " & i – 1 & "/" & lastRow – 1 & " (" & Format((i – 1) / (lastRow – 1), "0%") & ")"

' Récupérer les données
companyName = Trim(ws.Cells(i, 2).Value)
postalCode = Trim(ws.Cells(i, 4).Value)
address = Trim(ws.Cells(i, 3).Value) ' Adresse en colonne C

' Vérifier l'entreprise
If companyName <> "" And postalCode <> "" Then
result = CheckCompanyStatus(companyName, postalCode, address)
ws.Cells(i, 6).Value = result

' Mise en forme conditionnelle
If InStr(1, result, "ACTIF", vbTextCompare) > 0 Then
ws.Cells(i, 6).Interior.Color = RGB(198, 239, 206) ' Vert
ElseIf InStr(1, result, "FERMÉ", vbTextCompare) > 0 Then
ws.Cells(i, 6).Interior.Color = RGB(255, 199, 206) ' Rouge
Else
ws.Cells(i, 6).Interior.Color = RGB(255, 235, 156) ' Jaune/Orange pour indéterminé
End If

' Ajuster la hauteur de ligne pour accommoder le texte multilignes
ws.Rows(i).RowHeight = 60

' Formater pour le texte multiligne
ws.Cells(i, 6).WrapText = True

' Pause pour éviter de surcharger l'API
Sleep 300
End If
Next i

' Ajuster les colonnes
ws.Columns("F:F").AutoFit
ws.Columns("F:F").ColumnWidth = 50 ' Largeur fixe pour accommoder le texte

' Réinitialiser
Application.StatusBar = False
Application.ScreenUpdating = True

MsgBox "Traitement terminé!", vbInformation
End Sub

' Fonction Sleep (pause en millisecondes)
Sub Sleep(milliseconds As Long)
Dim start As Double
start = Timer
Do While Timer < start + (milliseconds / 1000)
DoEvents
Loop
End Sub