Sub ColoreCellules_RenommeFeuilles()
Dim w As Worksheet, cel As Range, t$, i&
Application.ScreenUpdating = False
For Each w In Worksheets
'---coloration des cellules avec liaison---
On Error Resume Next
For Each cel In w.UsedRange
t = Mid(cel.Formula, 2)
cel.Interior.ColorIndex = Range(t).Interior.ColorIndex 'couleur de fond
cel.Font.ColorIndex = Range(t).Font.ColorIndex 'couleur de police
Next
'---renommage provisoire de la feuille
t = Mid(w.[C3].Formula, 2)
On Error Resume Next
t = Range(t).Address
If Err = 0 Then
i = i + 1
w.Name = Chr(1) & i
End If
Next
'---renommage définitif---
For Each w In Worksheets
If w.Name Like Chr(1) & "*" Then
i = 0
t = ""
1 On Error Resume Next
w.Name = Epure(Left(w.[C3], 31 - Len(t))) & t
If Err Then
i = i + 1
t = "(" & i & ")"
GoTo 1
End If
End If
Next
'---création des fichiers (facultatif ici)---
CreationFichier
End Sub
Sub CreationFichier()
Dim n&, chemin$, w As Worksheet, t$, Wb As Workbook
Application.ScreenUpdating = False
Application.DisplayAlerts = False 'si un fichier existe déjà
n = Application.SheetsInNewWorkbook 'nombre de feuilles des nouveaux classeurs
Application.SheetsInNewWorkbook = 1
chemin = ThisWorkbook.Path & "\" 'chemin d'accès à adapter
For Each w In Worksheets
t = Mid(w.[C3].Formula, 2)
On Error Resume Next
t = Range(t).Address
If Err = 0 Then
Set Wb = Workbooks.Add 'nouveau document
w.Cells.Copy Wb.Sheets(1).Cells 'copie de la feuille
Wb.Sheets(1).UsedRange = Wb.Sheets(1).UsedRange.Value 'supprime les formules (facultatif)
Wb.Sheets(1).Name = w.Name 'renomme la feuille du nouveau document
Wb.SaveAs chemin & Epure(w.Name) 'crée le fichier sur le disque dur
Wb.Close
End If
Next
Application.SheetsInNewWorkbook = n
End Sub
Function Epure$(t$)
Dim interdit$, i As Byte
interdit = ":""/\<>?*[]|" 'caractères interdits dans les noms des feuilles OU des classeurs
For i = 1 To 11
t = Replace(t, Mid(interdit, i, 1), "#")
Next
Epure = t
End Function