Macro limitée nombre caractères

Bonjouuuuur

Ma macro me limite à 31 caractères dans ma feuille Excel (par exemple: je ne peux écrire "La fonction dérivée semble ne pas être exacte") Si je dépasse les 31 caractères, ma macro génère un message d'erreur "400" et ne fonctionne plus.

Hors, je possède des champs dépassant les 31 caractères.

Je souhaiterai une macro/ une fonction/une condition qui aurait le même principe que Recherche et Remplace mais de manière automatique.

Je m'explique:

Cela rechercherait toutes les "Editions" dépassant 31 caractères (ex: La Gazette du Comminges- (St Gaudens et Muret); L'Hebdo - 12 arrondissement Rodez) et cela le remplacerait par quelque chose inférieur à 31 caractères, selon MON choix (ex:La Gazette du Comminges; L'Hebdo - 12 Rodez)

(voir fichier joint pour davantage de clarté!)

Option Explicit

Public Sub cmdCreateWorksheets_Click()
'Declaration des variables
Dim ws As Worksheet, ws2 As Worksheet, WSnew As Worksheet
Dim lo As ListObject, lo2 As ListObject
Dim Cell As Range
Dim lRow As Long
    'Optimisation du code
    With Application
        .DisplayAlerts = False
        '.EnableEvents = False
        .ScreenUpdating = False
    End With
    'Suppression des feuilles sauf la feuille active (feuille Donnees)
    For Each ws In ActiveWorkbook.Worksheets
        If ws.Name <> ActiveSheet.Name Then ws.Delete
    Next ws
    'Initialisation des varialbes
    Set ws = ActiveSheet    'Feuilles Donnees
    Set lo = ws.ListObjects(1)    'Tableau feuille Données (Excel 2007+)

    If lo.ShowAutoFilter Then
        If lo.AutoFilter.FilterMode Then lo.AutoFilter.ShowAllData
    Else
        lo.ShowAutoFilter = True
    End If
    'Creation feuille temporaire (qui sera supprimée en fin de procédure)
    'La feuille va recevoir la liste des valeurs uniques de la colonne 8 (Field Num)
    Set ws2 = ActiveWorkbook.Worksheets.Add
    With ws2
        lo.ListColumns(6).Range.AutoFilter field:=6, Criteria1:="<>"
        lo.ListColumns(9).Range.AutoFilter field:=9, Criteria1:="<>"
        lo.ListColumns(9).Range.AutoFilter field:=10, Criteria1:="="
        lo.ListColumns(8).DataBodyRange.SpecialCells(xlCellTypeVisible).Copy
        .Cells(1).PasteSpecial xlPasteValues
        Application.CutCopyMode = False
        .Cells(1).CurrentRegion.RemoveDuplicates Columns:=1, Header:=xlNo
        'Nombre de valeurs uniques du filtre avancé
        lRow = .Cells(Rows.Count, 1).End(xlUp).Row
        'Pour chaque élément de la liste unique (Edition)
        For Each Cell In .Range("A1:A" & lRow)
            'On effectue le filtrage suivant l'item
            lo.Range.AutoFilter field:=8, Criteria1:="=" & Cell.Value
            'On crée la nouvelle feuille qui va recevoir les données filtrées
            Set WSnew = ActiveWorkbook.Worksheets.Add(after:=Worksheets(Worksheets.Count))
            'On nomme la nouvelle feuille avec la valeur de l'élément
            WSnew.Name = Cell.Value
            'On copie la plage filtrée (tableau feuille Données)
            lo.Range.SpecialCells(xlCellTypeVisible).Copy
            With WSnew
                With .Cells(1)
                    .PasteSpecial xlPasteColumnWidths
                    .PasteSpecial xlPasteValuesAndNumberFormats
                End With
                Application.CutCopyMode = False
                .Columns("A:E").Delete shift:=xlToLeft
                'On crée un nouveau tableau (Excel 2007+)
                Set lo2 = .ListObjects.Add(xlSrcRange, WSnew.Cells(1).CurrentRegion, , xlYes)
                With lo2
                    'On détermine le style du tableau
                    .TableStyle = "TableStyleLight1"
                    .ShowTotals = True
                    .ListColumns(5).TotalsCalculation = xlTotalsCalculationSum
                End With
                'Ono active la nouvelle feuille la mise en forme (minimale)
                .Activate
                .Cells(1).Select
                ActiveWindow.DisplayGridlines = False
            End With
        Next Cell
    End With

    lo.AutoFilter.ShowAllData
    'On supprime la feuille temporaire
    ws2.Delete
    'On active la feuille Données
    ws.Activate

    MsgBox "Terminé"

    With Application
        .DisplayAlerts = True
        '.EnableEvents = True
    End With
    'On réinitialise les variables (on vide la mémoire)
    Set lo = Nothing
    Set WSnew = Nothing: Set ws2 = Nothing: Set ws = Nothing

End Sub

Bonjour

Le problème vient du fait que tu veux renommer des feuilles avec des noms de longueur supérieure à 31 caractères, mais si tu limites le nom à 31 caractères tu as des noms qui ont les 31 premiers caractères identiques

Remplace la ligne correspondante

            'On crée la nouvelle feuille qui va recevoir les données filtrées
            Set WSnew = ActiveWorkbook.Worksheets.Add(after:=Worksheets(Worksheets.Count))
            'On nomme la nouvelle feuille avec la valeur de l'élément
            'WSnew.Name = Cell.Value
            WSnew.Name = IIf(Len(Cell) > 31, Left(Cell, 20) & "...." & Right(Cell, 7), Cell.Value)
            'On copie la plage filtrée (tableau feuille Données)

Banzaaaaaaaaaaaaaaaaaaaaaaaï ! Ça marche, merci !