Microsoft 365 Isoler, convertir et calculer une chaîne de caractères entre parenthèses

Sub filtering_projet()
Dim i&, x$
With Sheets("cible")
    .Cells(2, 2) = 0
    .Cells(3, 2) = 0
    .Cells(4, 2) = 1 And 0
    .Cells(5, 2) = 0 Or 0
    .Cells(6, 2) = 0 Or 0 Or 0
    .Cells(7, 2) = 0 Or 0 Or 0
    .Cells(8, 2) = 0 And (1 Or 1)
    .Cells(9, 2) = 0 And (0 Or 1 Or 0) And 1
    For i = 2 To 9
        x = ThisWorkbook.VBProject.VBComponents("Module1").CodeModule.Lines(i + 2, 1)
        .Cells(i, 1) = UCase(Mid(x, InStr(x, "=") + 2))
    Next
    .Columns(1).AutoFit 'ajustement largeur
End With
End Sub

Option Explicit
Dim flag As Boolean 'mémorise la variable

Sub project_filtering()
Application.ScreenUpdating = False
If Not flag Then
    Dim F As Worksheet, P As Range, i As Variant, c As Range, n&
    Set F = Sheets("DIV")
    Set P = [A3].CurrentRegion.Offset(1)
    P.Columns(2).Copy P.Columns(3)
    P.Columns(4) = ""
    '---3ème colonne---
    i = Application.Match([A1], F.Rows(5), 0)
    If IsError(i) Then Exit Sub
    P.Columns(3).Replace "~*", 1, xlPart
    For Each c In F.Columns(2).SpecialCells(xlCellTypeConstants)
        If c.Row > 6 Then P.Columns(3).Replace c, IIf(c(1, i - 1) = "", 0, 1)
    Next
    '---ajoute le code sous la ligne 27 pour remplir la 4ème colonne---
    With ThisWorkbook.VBProject.VBComponents("Module1").CodeModule
        For i = 1 To P.Rows.Count
            If P(i, 3) <> "" Then n = n + 1: .InsertLines 27 + n, "Range(""" & P(i, 4).Address(0, 0) & """) = " & P(i, 3)
        Next
    End With
    ThisWorkbook.Names.Add "n", n 'mémorise n dans un nom défini
End If
'---cette ligne est la ligne 27---
If Not flag Then Application.OnTime 1, "Executer" 'lancement différé
End Sub

Private Sub Executer()
flag = True
project_filtering 'lance la macro pour exécuter le code ajouté
flag = False
ThisWorkbook.VBProject.VBComponents("Module1").CodeModule.DeleteLines 28, [n] 'supprime le code ajouté
End Sub

Option Explicit
Dim flag1 As Boolean, flag2 As Boolean 'mémorise les variables

Sub project_filtering()
Dim F As Worksheet, P As Range, i As Variant, c As Range
Application.ScreenUpdating = False
If Not flag1 Then
    ThisWorkbook.Names.Add "t", Timer 'nom défini pour mesurer la durée
    ThisWorkbook.Names.Add "paquet", 500 'nom défini, adapter le nombre
    Set F = Sheets("DIV")
    Set P = [A3].CurrentRegion.Offset(1)
    P.Name = "P" 'plage nommée
    ThisWorkbook.Names.Add "debut", 1 'nom défini
    P.Columns(2).Copy P.Columns(3)
    P.Columns(4) = ""
    '---3ème colonne---
    i = Application.Match([A1], F.Rows(5), 0)
    If IsError(i) Then Exit Sub
    P.Columns(3).Replace "~*", 1, xlPart
    For Each c In F.Columns(2).SpecialCells(xlCellTypeConstants)
        If c.Row > 6 Then P.Columns(3).Replace c, IIf(c(1, i - 1) = "", 0, 1)
    Next
End If
If Not flag2 Then
    '---ajoute le code sous la ligne 33 pour remplir la 4ème colonne---
    With ThisWorkbook.VBProject.VBComponents("Module1").CodeModule
        For i = [debut] To [debut] + [paquet] - 1
            If [debut] = 1 Then .InsertLines 34 + i - [debut], ""
            .ReplaceLine 34 + i - [debut], IIf(Range("P").Cells(i, 3) = "", "", "Range(""" & Range("P").Cells(i, 4).Address(0, 0) & """) = " & Range("P").Cells(i, 3))
        Next
    End With
End If
'---ici ligne 33---
If Not flag2 Then Application.OnTime 1, "Executer" 'lancement différé
End Sub

Private Sub Executer()
flag1 = True: flag2 = True
project_filtering 'lance la macro pour exécuter le code ajouté
flag1 = False: flag2 = False
If [debut] + [paquet] < Range("P").Rows.Count - 1 Then
    ThisWorkbook.Names.Add "debut", [debut] + [paquet]
    flag1 = True
    project_filtering 'lance la macro pour traiter la plage suivante
    flag1 = False
Else
    ThisWorkbook.VBProject.VBComponents("Module1").CodeModule.DeleteLines 34, [paquet] 'supprime les lignes de code ajoutées
    Application.ScreenUpdating = True
    MsgBox Range("P").Rows.Count - 1 & " lignes traitées par paquets de " & [paquet] & vbLf & vbLf & "Durée " & Format(Timer - [t], "0.00 \sec")
End If
End Sub

Sub test()
'(1 OR 0) AND NOT (0 OR 1)
MsgBox EvaluationCode("Banane=1:fraise=0:pomme=0:Groseille=1", "(Banane OR fraise) AND NOT (pomme OR Groseille)")
MsgBox EvaluationCode(Equation:="(1 OR 0) AND NOT (0 OR 1)")
End Sub
Function EvaluationCode(Optional Variable As String, Optional Equation As String)
With CreateObject("ScriptControl")
    .Language = "VbScript"
    .ExecuteStatement Variable & vbCrLf & "V=" & Equation
    EvaluationCode = .Eval("v")
End With
End Function

Option Explicit
Option Compare Text

Public l As Long, col As Integer
Dim Applicability As Variant, sepn As Variant
Dim Besoin As String, TBC As String
Dim cpt As Integer, DIV_Line As Integer
Dim DIV_object As Range, filter_name As Range
Dim DIV As Worksheet, Synthese As Worksheet
Dim PlageDeRecherche As Range

Dim filter As String
Dim dernligne As Integer, derncol As Integer


Sub project_filtering()

Set DIV = Sheets("DIV")
Set PlageDeRecherche = DIV.Columns(2)
Set Synthese = Sheets("Feuil1")
dernligne = Synthese.Range("A65536").End(xlUp).Row


filter = Sheets("Feuil1").Cells(1, 1).Value
'on traite le cas du sans filtre de manière simple puisque pas de filtre = on prends toutes les lignes
Select Case filter
Case Is = "No_Filter"
    For l = 4 To dernligne
    Synthese.Cells(l, 3) = 1
    Next
' on traite le cas des autres filtres
Case Else
Set filter_name = DIV.Rows(5).Find(what:=filter, LookAt:=xlWhole)
col = filter_name.Column


    For l = 4 To dernligne ' on balaye toutes les lignes de la feuille synthèse
        Applicability = Synthese.Cells(l, 2).Value ' on sort l'applicabilité
        ' on traite l'applicabilité pour la convertir en formule binaire
        Select Case Applicability
            Case Is = "*"
            Synthese.Cells(l, 3) = "1"
            Case Else
                sepn = Split(Applicability, " ") 'permet de scinder le commentaire avec le séparateur "espace"
                If UBound(sepn) > -1 Then
                    For cpt = LBound(sepn) To UBound(sepn)
                    sepn(cpt) = Replace(sepn(cpt), "(", "")
                    sepn(cpt) = Replace(sepn(cpt), ")", "")
                    Set DIV_object = PlageDeRecherche.Find(what:=sepn(cpt), LookAt:=xlWhole)
                        If Not DIV_object Is Nothing Then
                        DIV_Line = DIV_object.Row
                            TBC = DIV.Cells(DIV_Line, col).Value
                            Select Case TBC
                            Case Is = "X" 'si c'est applicable on met "1"
                            Applicability = Replace(Applicability, sepn(cpt), 1, , 1)
                            Case Is = "?" 'par defaut on prend en compte les Applicabilités du type "?"
                            Applicability = Replace(Applicability, sepn(cpt), 1, , 1)
                            Case Else 'si c'est non-applicable on met "0"
                            Applicability = Replace(Applicability, sepn(cpt), 0, , 1)
                            End Select
                        End If
                    Next
                End If
        Synthese.Cells(l, 3) = Applicability
        Synthese.Cells(l, "D") = EvaluationCode(Equation:=CStr(Applicability))
        End Select
        Synthese.Columns(3).AutoFit 'ajustement largeur
    Next
End Select

MsgBox ("etape1: done")

' ici je souhaite ensuite rebalayer les lignes en convertissant la forumule binaire précédement calculée en un resultat 0 ou 1
MsgBox ("Le filtre " & filter & " a été appliqué")

End Sub
Function EvaluationCode(Optional Variable As String, Optional Equation As String)
With CreateObject("ScriptControl")
    .Language = "VbScript"
    .ExecuteStatement Variable & vbCrLf & "V=" & Equation
    EvaluationCode = .Eval("v")
End With
End Function

Option Explicit

Private dernligne As Integer, l As Integer
Private feuil1 As Worksheet
Private formula As String

Sub req_mac()

Set feuil1 = Sheets("Feuil1")
dernligne = feuil1.Range("C65536").End(xlUp).Row

    For l = 12 To dernligne
    formula = feuil1.Cells(l, 3).Value
             'on integre la formule binaire dans le code de maniere dynamique
             With ThisWorkbook.VBProject.VBComponents("Module3").CodeModule
            .ReplaceLine 19, "feuil1.cells(" & l & ",4) = " & formula
             'ici la ligne de code dynamique qui calcul la formule binaire automatiquement
             End With
' ici s’implémente la ligne dynamique
    Next
End Sub