Microsoft 365 Zone nommée

Sub ListerLesZonesNommees()

Dim LigneTitreZone As Long, DerniereLigneZNommee As Long
Dim MaZoneNommee As Name
Dim Wb As Workbook
Dim ShListesZones As Worksheet

    
    
    Set Wb = ActiveWorkbook
    Set ShListesZones = Wb.Sheets.Add
 
    With ShListesZones
         .Cells.Clear
         LigneTitreZone = 10
         DerniereLigneZNommee = LigneTitreZone + 1
         With .Range(.Cells(LigneTitreZone, 1), .Cells(LigneTitreZone, 4))
            .Value = Array("Nom", "Adresse", "Onglet", "Nom 2")
            .Interior.Color = RGB(255, 255, 0)
            .Font.Bold = True
         End With
        
         For Each MaZoneNommee In Wb.Names
             Select Case Mid(MaZoneNommee.Name, 1, 2)
                    Case "_x", "wr"
                    
                    Case Else
                         .Cells(DerniereLigneZNommee, 1).Value = "'" & MaZoneNommee.RefersTo
                         .Cells(DerniereLigneZNommee, 2).Value = MaZoneNommee.Name
                         If InStr(1, MaZoneNommee.Name, "!", vbTextCompare) > 0 Then
                            .Cells(DerniereLigneZNommee, 3).Value = Split(MaZoneNommee.Name, "!")(0)
                            .Cells(DerniereLigneZNommee, 4).Value = Split(MaZoneNommee.Name, "!")(1)
                         Else
                          .Cells(DerniereLigneZNommee, 4).Value = MaZoneNommee.Name
                         End If
                         DerniereLigneZNommee = DerniereLigneZNommee + 1
             End Select
         Next MaZoneNommee
    
    End With

    Set ShListesZones = Nothing
    Set Wb = Nothing

End Sub