onglet changeant de titre

Option Explicit
Private Sub Workbook_SheetActivate(ByVal Sh As Object)
On Error Resume Next
If ActiveSheet.Name <> "données" Then ActiveSheet.Name = "FACT " & Range("f8").Value
If ActiveSheet.Name = "FACT 0" Then ActiveSheet.Tab.Color = 255
If ActiveSheet.Name <> "données" And ActiveSheet.Name <> "FACT 0" Then ActiveSheet.Tab.ThemeColor = xlThemeColorLight1
End Sub

Private Sub Workbook_Open()
Dim c As Range, w As Worksheet
'---suppression des espaces superflus (il y en avait !!!)---
For Each c In Sheets("données").Range("B5", Sheets("données").[B65536].End(xlUp))
  c = Application.Trim(c) 'SUPPRESPACE
Next
'---nom des onglets---
For Each w In Worksheets
  Workbook_SheetChange w, w.[F8]
Next
End Sub

Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Source As Range)
Dim c As Range, i As Integer
If Left(Sh.Name, 4) = "FACT" Then
  If Not Intersect(Source, Sh.[F8]) Is Nothing Then
    Set c = Sheets("données").[B:B].Find(Sh.[F8], , xlValues, xlWhole)
    On Error Resume Next
    If c Is Nothing Or Sh.[F8] = "" Then
      Do
        i = i + 1
        Sh.Name = "FACT " & i
        If Sh.Name = "FACT " & i Then Exit Do
      Loop
      Sh.Tab.ColorIndex = 3 'rouge
    Else
      Sh.Name = "FACT =données!" & c.Address(0, 0)
      If Sh.Name <> "FACT =données!" & c.Address(0, 0) Then _
        MsgBox "Le nom '" & c & "' en " & Sh.Name & "!F8 est déjà utilisé !"
      Sh.Tab.ColorIndex = 1 'noir
    End If
  End If
End If
End Sub

Private Sub Workbook_Open()
Dim c As Range, w As Worksheet
'---suppression des espaces superflus (il y en avait !!!)---
For Each c In Sheets("données").Range("B5", Sheets("données").[B65536].End(xlUp))
  c = Application.Trim(c) 'SUPPRESPACE
Next
'---nom des onglets---
For Each w In Worksheets
  Workbook_SheetChange w, w.[F8]
Next
End Sub

Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Source As Range)
Dim c As Range, i As Integer
If Left(Sh.Name, 4) = "FACT" Then
  If Not Intersect(Source, Sh.[F8]) Is Nothing Then
    Set c = Sheets("données").[B:B].Find(Sh.[F8], , xlValues, xlWhole)
    On Error Resume Next
    If c Is Nothing Or Sh.[F8] = "" Then
      Do
        i = i + 1
        Sh.Name = "FACT " & i
        If Sh.Name = "FACT " & i Then Exit Do
      Loop
      Sh.Tab.ColorIndex = 3 'rouge
    Else
      Sh.Name = "FACT " & c
      If Sh.Name <> "FACT " & c Then _
        MsgBox "Le nom '" & c & "' en " & Sh.Name & "!F8 est déjà utilisé !"
      Sh.Tab.ColorIndex = 1 'noir
    End If
  End If
End If
End Sub

Private Sub Worksheet_Deactivate()
Dim P As Range
Set P = Range("B6", [B65536].End(xlUp))
[O2:O65536].ClearContents 'RAZ
If P.Row > 5 Then
  [O2].Resize(P.Rows.Count) = P.Value
  [O2].Resize(P.Rows.Count).Sort [O2], Header:=xlNo 'tri
End If
[O2].Resize(Application.Max(Application.CountA(P), 1)).Name = "Liste"
End Sub