I am using the code below to split one WorkSheet in to several tabs within the same WorkBook, based on the content of Column B. The macro automatically names each new tab, based on the text in Column B. The problem I have is that if the length of the text in Column B exceeds the 31 character limit, the sheet just gets named 'Sheet X', where 'X' is the next new sheet number, but in doing so, the data doesn't get copied to the sheet correctly.

Is there a way to 'truncate' and sheet names the code generates, so that the sheet uses the Excel maximum of 31 characters, when running the code. I don't know enough about vba to understand which lines of code are generating the names in the first place, I assume it is the section around 'Get a temporary list of unique values from vCol'. I can't truncate the text on the master sheet because this is used in various lookups.

Many thanks.

Sub SplitToSeparateTabs()


Dim LR As Long, Itm As Long, MyCount As Long, vCol As Long, iCol As Long
Dim ws As Worksheet, MyArr As Variant, vTitles As String, TitleRow As Long

Application.ScreenUpdating = False

'Column to evaluate from, column A = 1, B = 2, etc.

'    Dim vCol, i As Long
    vCol = Application.InputBox("Type the Column Number to Reference", , , , , , , 1)
    If vCol = False Then Exit Sub
 
'Sheet with data in it
   Set ws = Sheets("All")

'Range where titles are across top of data, as string, data MUST have titles in this row, edit to suit your titles locale
    vTitles = "1:1"
    TitleRow = Range(vTitles).Cells(1).Row

'Spot bottom row of data
   LR = ws.Cells(ws.Rows.Count, vCol).End(xlUp).Row

'Get a temporary list of unique values from vCol
    iCol = ws.Columns.Count
    ws.Cells(1, iCol) = "key"
   
    For Itm = 2 To LR
        On Error Resume Next
        If ws.Cells(Itm, vCol) <> "" And Application.WorksheetFunction _
            .Match(ws.Cells(Itm, vCol), ws.Columns(iCol), 0) = 0 Then
               ws.Cells(ws.Rows.Count, iCol).End(xlUp).Offset(1) = ws.Cells(Itm, vCol)
        End If
    Next Itm
    
'Sort the temporary list
    ws.Columns(iCol).Sort Key1:=ws.Cells(2, iCol), Order1:=xlAscending, _
        Header:=xlYes, OrderCustom:=1, MatchCase:=False, _
        Orientation:=xlTopToBottom, DataOption1:=xlSortNormal

'Put list into an array for looping
    MyArr = Application.WorksheetFunction.Transpose _
        (ws.Columns(iCol).SpecialCells(xlCellTypeConstants))

'clear temporary list
    ws.Columns(iCol).Clear

'Turn on the autofilter
    ws.Range(vTitles).AutoFilter

'Loop through list one value at a time
'The array includes the title cell, so start at the second value in the array
'In case values are numerical, convert them to text with ""
    For Itm = 2 To UBound(MyArr)
        ws.Range(vTitles).AutoFilter Field:=vCol, Criteria1:=MyArr(Itm) & ""
   
        If Not Evaluate("=ISREF('" & MyArr(Itm) & "'!A1)") Then    'create sheet if needed
            Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = MyArr(Itm) & ""
        Else                                                      'clear sheet if it exists
            Sheets(MyArr(Itm) & "").Move After:=Sheets(Sheets.Count)
            Sheets(MyArr(Itm) & "").Cells.Clear
        End If
   

        ws.Range(TitleRow & ":" & LR).Copy
        With Sheets(MyArr(Itm) & "").Range("A1")
            .PasteSpecial xlPasteColumnWidths
            .PasteSpecial xlPasteValuesAndNumberFormats, , False, False
            .PasteSpecial xlPasteFormats, , False, False
            
        LastRow = Range("D65536").End(xlUp).Offset(2, 0).Row
        Range("D" & LastRow) = "=Sum(D1:D" & LastRow - 1 & ")"
        Range("D" & LastRow).Font.Bold = True
        Range("D" & LastRow).HorizontalAlignment = xlCenter
        Range("D" & LastRow).NumberFormat = "#,##0"
        Range("C" & LastRow) = "Total"
        Range("C" & LastRow).Font.Bold = True
        

        End With
        Application.CutCopyMode = False

                   
        ws.Range(vTitles).AutoFilter Field:=vCol
        MyCount = MyCount + Sheets(MyArr(Itm) & "").Range("A" & Rows.Count) _
                             .End(xlUp).Row - Range(vTitles).Rows.Count
 '       Sheets(MyArr(Itm) & "").Columns.AutoFit
        
        
    Next Itm
   
'Cleanup
    ws.AutoFilterMode = False
        ws.Activate
        
'    MsgBox "Rows with data: " & (LR - TitleRow) & vbLf & "Rows copied to other sheets: " _
 '               & MyCount & vbLf & "Hope they match!!"

Application.ScreenUpdating = True
End Sub