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

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