Code qui bloque Excel

Private Sub Worksheet_Change(ByVal Target As Range)
' ne se lance que si des valeurs ont changées sur la feuille Synthèse
Dim xs

If Intersect(Target, Range("b:b")) Is Nothing Then Exit Sub
  'on va examiner toutes les cellules B2 des autres feuilles
  For Each xs In Worksheets
    'on vérifie qu'on est sur une autre feuille que "Synthése"
    If xs.CodeName <> Me.CodeName Then
      'on affecte le contenu de la cellule B2 au nom de l'onglet
      xs.Name = xs.Range("b2").Value
    End If
  Next xs
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
' ne se lance que si des valeurs ont changées sur la feuille Synthèse
Dim xs, plageColB As Range, CelluleSource As Range, ErrPrem As Boolean

If Intersect(Target, Range("b:b")) Is Nothing Then Exit Sub
  'plage de la colonne B de la feuille Synthése"
  With Sheets("Synthése")
  Set plageColB = .Range("b4:b" & Rows.Count): End With
  ' on va examiner toutes les cellules B2 des autres feuilles
  For Each xs In Worksheets
    ErrPrem = False     'pas d 'erreur au départ
    ' on vérifie qu'on est sur une autre feuille que "Synthése"
    If xs.CodeName <> Me.CodeName Then
      ' on vérifie que la formule de type =Synthése!Bnn
      ' référence bien une cellule de la colonne B de la feuille "Synthése"
      On Error GoTo errFORMULE
      Set CelluleSource = Range(Mid(xs.Range("b2").Formula, 2, 999))
      If Not ErrPrem Then
        If Not Intersect(CelluleSource, plageColB) Is Nothing Then
          ' la cellule source de B2 est bien dans plageColonneA
          On Error GoTo errRENOMMER
          'on affecte le contenu de la cellule B2 au nom de l'onglet
          xs.Name = xs.Range("b2").Value
        End If
      End If
    End If
  Next xs
  Exit Sub
 
errFORMULE:
  ErrPrem = True
  Resume Next
 
errRENOMMER:
  'mettre l'instruction Msgbox en commentaire si vous ne voulez pas de msg
  MsgBox "Erreur n°: " & Err.Number & vbLf & Err.Description & vbLf & vbLf & _
    "La feuille: <" & xs.Name & " > n'a pas pu être renommée", vbCritical
  Resume Next   ' Conservez cette instruction
End Sub