Bouton qui s'auto-détruit

Option Explicit
Public Const NomBouton$ = "MonBouton"

Sub CreeBoutonFeuilleEtCode()
Dim Btn As OLEObject, VbCodeMod As Object
Dim i&, Code$
  
  'le bouton
  Set Btn = ActiveSheet.OLEObjects.Add _
                      (ClassType:="Forms.CommandButton.1") '
  i = ActiveSheet.OLEObjects.Count
  With Btn
    .Object.Caption = "Test bouton " & i
    .Object.Font.Bold = True
    .Top = ActiveCell(1, 2).Top
    .Left = ActiveCell(1, 2).Left
    .Name = NomBouton & i
    .Visible = True
    .Width = 150
  End With
  
  'son code
  Set VbCodeMod = ActiveWorkbook.VBProject. _
                  VBComponents(Btn.Parent.CodeName).CodeModule
               
  Code = "Private Sub " & Btn.Name & "_Click()" & vbLf
  Code = Code & "  MsgBox ""Test réussi : " & Btn.Name & "" & vbLf
  Code = Code & "  ActiveCell.Select" & vbLf
  Code = Code & "End Sub"
  
  VbCodeMod.AddFromString Code
  
End Sub 'fs

Sub NettoieBoutonEtCode()
Dim NomBtn$, Shp As OLEObject, Sht As Worksheet
 Dim Deb, NbLi As Integer
  For Each Sht In ActiveWorkbook.Sheets
    For Each Shp In Sht.OLEObjects
      NomBtn = Shp.Name
      If Left(NomBtn, 9) = NomBouton Then
        Shp.Delete
        With ActiveWorkbook.VBProject. _
              VBComponents(Sht.CodeName).CodeModule
          Deb = .ProcStartLine(NomBtn & "_Click", 0)
          NbLi = .ProcCountLines(NomBtn & "_Click", 0)
          .DeleteLines Deb, NbLi
        End With
      End If
    Next Shp
  Next Sht
End Sub

Private Sub CommandButton1_Click()
CreeBoutonFeuilleEtCode
End Sub

Private Sub CommandButton2_Click()
NettoieBoutonEtCode
End Sub

If Reference = Cells(i, 4).Value Then
Cells(i, 4).EntireRow.Interior.Color = RGB(174, 240, 194)
ActiveSheet.Buttons.Add(BLeft, BTop, BWidth, BHeight).Select
BTop = BTop + 11.25
Buttons.Caption = "Arrêter"
'Lien vers le Sub du bouton "Arrêter"
End If

Private Sub Button2_click()
Button2_click.delete
end sub