Sheet Names to long when creating New worksheet

[John_Daly]

Hi There,

I am running the below to divide up a worksheet into different worksheets based on column A having the same value. It works fine, but sometimes Column A is too long and I get a 1004 error as the character length has exceeded 31. Is it possible to add some code here to change the worksheet name to set the worksheet name to just 30 characters and still have the full detail in the column



Sub Split_Sht_in_Separate_Shts()

Const FirstC As String = "A" '1st column

Const LastC As String = "G" 'last column

Const sCol As String = "A" '<<< Criteria in Column A

Const shN As String = "data1" '<<< Source Sheet

Dim ws As Worksheet, ws1 As Worksheet

Set ws = Sheets(shN)

Dim rng As Range

Dim r As Long, c As Long, x As Long, r1 As Long

Application.ScreenUpdating = False

r = ws.Range(FirstC & ":" & LastC).Find(What:="*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row

c = ws.Cells.Find(What:="*", SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column + 2

Set rng = ws.Range(ws.Cells(1, FirstC), ws.Cells(r, LastC))

ws.Range(sCol & ":" & sCol).Copy

ws.Cells(1, c).PasteSpecial xlValues

Application.CutCopyMode = False

ws.Cells(1, c).Resize(r).RemoveDuplicates Columns:=1, Header:=xlYes

r1 = ws.Cells(Rows.Count, c).End(xlUp).Row

ws.Cells(1, c).Resize(r1).Sort Key1:=ws.Cells(1, c), Header:=xlYes

ws.AutoFilterMode = False

Application.DisplayAlerts = False

For x = 2 To r1

For Each ws1 In Sheets

If ws1.Name = ws.Cells(x, c) Then ws1.Delete

Next

Next

Application.DisplayAlerts = True

For x = 2 To r1

ws.Range(ws.Cells(1, sCol), ws.Cells(r, sCol)).AutoFilter Field:=1, Criteria1:=ws.Cells(x, c)

Set ws1 = Worksheets.Add(after:=Worksheets(Worksheets.Count))

ws1.Name = ws.Cells(x, c).Value

rng.SpecialCells(xlCellTypeVisible).Copy

Range("A1").PasteSpecial Paste:=xlPasteFormats

Range("A1").PasteSpecial Paste:=xlPasteColumnWidths

Range("A1").PasteSpecial Paste:=xlPasteValues

Application.CutCopyMode = False

Next x

With ws

.AutoFilterMode = False

.Cells(1, c).Resize(r).ClearContents

.Activate

.Range("A1").Select

End With

Application.ScreenUpdating = True

End Sub

 

[mumps]

Try replacing this line of code:

ws1.Name = ws.Cells(x, c).Value

with this one:

ws1.Name = Left(ws.Cells(x, c).Value, 31)

 

[John_Daly]

Perfect - Thanks very much - Have a nice day!

 

[mumps]

You are very welcome.