XL 2016 Renommer onglets en fonction d une liste

[aragdur]

Bonjour

J ai un fichier avec une base de données.
J ai mis en place une macro (récupérée sur le net) de type filtre auto avec nommage de l onglet en fonction d un code ( c est le filtre).
Les codes sont de type :
20.970
1b.709
2g.126
...

Ce nommage d onglet ne me convient pas.
Ça manque de clarté immédiate.

Du coup, je voulais faire une autre macro pour renommer les onglets en fonction du titre actuel de l onglet via une liste de données.

Ça serait du style :
L onglet est égal à 01.234, alors recherche dans liste feuille 1 A1:A500 puis inscrire en titre de l onglet la donnée correspondant en colonne B, soit pomme (par exemple).

facile svp ?

 

[aragdur]

Je vous mets aussi ma macro :
Pour info, mes codes sont en colonne D (D11 le début) et la correspondance en colonne E (E11 du coup).

Sub Filtre_Export()

Dim Rg As Range, Rg1 As Range, E As Range

Dim Sh As Worksheet, Sh1 As Worksheet



Application.ScreenUpdating = False



With Worksheets("Validité VMP") 'Nom Feuille à adapter

Set Rg = .Range("D10" & .Range("D65536").End(xlUp).Row)

End With



Set Sh = Worksheets.Add

On Error Resume Next

With Rg

.AdvancedFilter xlFilterCopy, , Sh.Range("A10"), True

Worksheets(.Parent.Name).ShowAllData

End With



With Sh

Set Rg1 = .Range("A11:A" & .Range("A65536").End(xlUp).Row)

End With



For Each c In Rg1

Set Sh1 = Worksheets.Add(after:=Sheets(Sheets.Count))

Sh1.Name = c.Value

With Rg

.AutoFilter Field:=1, Criteria1:=c.Value

.SpecialCells(xlCellTypeVisible) _

.EntireRow.Copy Sh1.Range("A10")

End With

Next

Rg.AutoFilter

Application.DisplayAlerts = False

Sh.Delete

Application.DisplayAlerts = True

End Sub