limit tab creation to 30 characters in excel vba

Hi-
So I have a macro that creates tabs based on client names, however if it's greater than 30 characters it just doesn't create the tab. I'd like to resolve this, if that means limiting the tab creation to 30 characters in excel vba, then maybe that's the way to do it.

If anyone could help tweak, much appreciated:

Sub Tab_Clients()
Dim lr As Long, MaxRow As Long
Dim ws As Worksheet
Dim WSPY As Worksheet
Dim vcol, i As Integer
Dim icol As Long
Dim myarr As Variant
Dim title As String
Dim titlerow As Integer
Dim cCell As Range
Dim FirstAddress As String
Dim ThisYr As String, LastYr As String

'---> Disable Events
With Application
    .EnableEvents = False
    .ScreenUpdating = False
    .DisplayAlerts = False
End With

vcol = 1
Set ws = Sheets("Filtered from Prev Year")
LastYr = Format(Year(Now) - 1, "@")

Set WSPY = Sheets("Filtered from Current Year")
ThisYr = Format(Year(Now), "@")

lr = ws.Cells(ws.Rows.Count, vcol).End(xlUp).Row
title = "A1:BG1"
titlerow = ws.Range(title).Cells(1).Row
icol = ws.Columns.Count
ws.Cells(1, icol) = "Unique"
For i = 2 To lr
    On Error Resume Next
    If ws.Cells(i, vcol) <> "" And Application.WorksheetFunction.Match(ws.Cells(i, vcol), ws.Columns(icol), 0) = 0 Then
        ws.Cells(ws.Rows.Count, icol).End(xlUp).Offset(1) = ws.Cells(i, vcol)
    End If
Next

myarr = Application.WorksheetFunction.Transpose(ws.Columns(icol).SpecialCells(xlCellTypeConstants))
ws.Columns(icol).clear
For i = 2 To UBound(myarr)
    ws.Range(title).AutoFilter field:=vcol, Criteria1:=myarr(i) & ""
    If Not Evaluate("=ISREF('" & myarr(i) & "'!A1)") Then
        Sheets.Add(after:=Worksheets(Worksheets.Count)).Name = myarr(i) & ""
    Else
        Sheets(myarr(i) & "").Move after:=Worksheets(Worksheets.Count)
    End If
    If Sheets(myarr(i) & "").Range("A1") <> "Year" Then
        ws.Range("A" & titlerow & ":A" & lr).EntireRow.Copy Sheets(myarr(i) & "").Range("A1")
        Sheets(myarr(i) & "").Range("A1").EntireColumn.Insert
        Sheets(myarr(i) & "").Range("A1") = "Year"
        Sheets(myarr(i) & "").Range("A1").Offset(1, 0) = LastYr
    Else
        ws.Range("A" & titlerow & ":A" & lr).EntireRow.Copy Sheets(myarr(i) & "").Range("A1")
        Sheets(myarr(i) & "").Range("A1").Offset(1, 0).Insert xlShiftToRight
        Sheets(myarr(i) & "").Range("A1").Offset(1, 0) = LastYr
    End If
    MaxRow = Sheets(myarr(i) & "").Range("A" & Sheets(myarr(i) & "").Rows.Count).End(xlUp).Row + 1
    
    '---> Get Data from Last Year
    With WSPY.UsedRange
        Set cCell = .Find(What:=myarr(i), LookIn:=xlValues, lookat:=xlWhole, MatchCase:=False)
        If Not cCell Is Nothing Then
            FirstAddress = cCell.Address
            Do
                cCell.EntireRow.Copy Sheets(myarr(i) & "").Range("A" & MaxRow)
                Sheets(myarr(i) & "").Range("A" & MaxRow).Insert xlShiftToRight
                Sheets(myarr(i) & "").Range("A" & MaxRow) = ThisYr
                MaxRow = MaxRow + 1
                Set cCell = .FindNext(cCell)
            Loop While Not cCell Is Nothing And cCell.Address <> FirstAddress
        End If
    End With
    
    '---> Columns Autofit
    Sheets(myarr(i) & "").Columns.AutoFit

CHARTCLIENT2

Next
ws.AutoFilterMode = False
ws.Activate

'---> Enable Events
With Application
    .EnableEvents = False
    .ScreenUpdating = False
    .DisplayAlerts = False
End With

MsgBox "Creation of Clients tab done.", vbExclamation
End Sub

Open in new window

jfrank85Asked:
Who is Participating?
I wear a lot of hats...

"The solutions and answers provided on Experts Exchange have been extremely helpful to me over the last few years. I wear a lot of hats - Developer, Database Administrator, Help Desk, etc., so I know a lot of things but not a lot about one thing. Experts Exchange gives me answers from people who do know a lot about one thing, in a easy to use platform." -Todd S.

Martin LissOlder than dirtCommented:
I'm probably missing it but I don't see anything about Tabs or IndentLevel in that code. In any case could you attach a workbook and describe how to reproduce the problem?
0
SimonCommented:
Line 44 - 48 in your listing...

Change to this
If Not Evaluate("=ISREF('" & left(myarr(i),30)  & "'!A1)") Then
        Sheets.Add(after:=Worksheets(Worksheets.Count)).Name = left(myarr(i),30) & ""
    Else
        Sheets(myarr(i) & "").Move after:=Worksheets(Worksheets.Count)
    End If
0
Martin LissOlder than dirtCommented:
Oh, "tab" as in sheet - doh!
0
Get expert help—faster!

Need expert help—fast? Use the Help Bell for personalized assistance getting answers to your important questions.

jfrank85Author Commented:
SimonAdept, rather than shortening the name to only 30 characters, it doesn't include the tab at all..

i.e. I had a client name that was 35 characters and it didn't create a worksheet for it at all. just skipped over it.. This happened a few times. I had a client name with 44 characters, same thing..


thanks.
0
SimonCommented:
You will need to step thru the code and take note of the error message. The issue may be that although the complete client name is unique, the first 30 characters of it are not.

e.g.
That sheet name is already in use. Enter a sheet name that is not in use by another sheet. (1004)
or
While renaming a sheet or chart, you entered an invalid name. Try one of the following:

• Make sure the name you entered does not exceed 31 characters.
• Make sure the name does not contain any of the following characters:  :  \  /  ?  *  [  or  ]
• Make sure you did not leave the name blank.  (1004)
That sheet name is already in use. Enter a sheet name that is not in use by another sheet. (1004)


This simplified example code shows what happens when the name gets too long, and how to display the error.
Sub Example()
Dim x As Integer
Dim myarr()
On Error GoTo ErrorTrap
For x = 28 To 34
ReDim myarr(x)
myarr(x) = String(x, "v")
With ActiveWorkbook
'.Sheets(Add).Name = "x" & x
.Sheets.Add(after:=Worksheets(Worksheets.Count)).Name = myarr(x)
End With
Next x

ErrorTrap:
Debug.Print Err.Description & " (" & Err.Number & ")"
Stop
Resume
End Sub

Open in new window

0
jfrank85Author Commented:
Thanks for your reply. The uniqueness of the first 30 characters inst the issue. how can i apply this check above into my existing code? how can i figure out where the issue is?
0
FarWestCommented:
You can have a form that has drop down for all customers that (or a cell in home sheet) that will activate selected customer sheet while you name tabs or sheets using serial or client number.
Or you can name only with the first 38 or 39 letters and if name exists Add a number to the name from 2 to 9 to skip sheet name duplication
0
SimonCommented:
You have 'On Error Resume Next' in line 39 of your code, which can hide a multitude of problems. It is acceptable to use it just for a single line or short block of code, but you should always follow it as soon as possible with
on error goto 0

Open in new window

or
on error goto ErrorHandler

Open in new window

and then have an error handler block of code at the bottom of your sub to deal with errors.

I suggest you put On Error GoTo 0 in at line 44 of your code so that errors after that line are reported to you. That will let you see where and what error is occurring.

Ideally, you should not use 'on error resume next' at all, or if time constraints force it on you, at least check the value of Err after each command. For example...
On error resume next
x=command that might result in an error
if err<>0 then debug.print err.description else
on error goto 0

Open in new window


If you're struggling, please try posting a sample workbook with just enough non-sensitive data in to demonstrate the problem.
0
gowflowCommented:
ok here is my solution.

I have modified your original workbook to simulate most of clients having names more than 30 Char and left only 3 that are way below 30 to make sure the new routine works in all cases.

If you are interested in the technical side of the solution I will lay down what are the new modifications brought forward so it works in these cases.

1. Format the name to be paded with 30 Char minimum

First change is in the following Instruction:
ws.Cells(ws.Rows.Count, icol).End(xlUp).Offset(1) = Trim(Left(ws.Cells(i, vcol) & Space(30), 30))

when we are looping thru all clients name we now have to pad the name with 30 blanks additional then take the first 30 characters and also remove all blanks so we get a clean name. This is done at 2 instances in the sheet of This year and also in sheet of last year you will find this same instruction lower in the code also changed as follows:

WSThis.Cells(WSThis.Rows.Count, icol).End(xlUp).Offset(1) = Trim(Left(WSThis.Cells(i, vcol) & Space(30), 30))
This is when we are looping to find all Clients that have records in This year but not in previous year.

2. Filter by Sheet Name of Client & everything after the 30 chars

Now we also need to adjust the Autofiltering when we filter Client name to look for everything that is after the 30 characters. by introducing the * and this is in the instruction below
ws.Range(title).AutoFilter field:=vcol, Criteria1:=myarr(i) & "*"

As now the client name in the Array is only 30 characters where in fact on the worksheet it is still at 40 50 or even 100 characters.

You will find also this amendment in the same instruction below when looking for This year data
WSThis.Range(title).AutoFilter field:=vcol, Criteria1:=myarr(i) & "*"

3. Look for Part of Client Name in the Table

Also by the same token when we look to see if a Client has data in a certain year now the value stored in the Array is only 30 characters but in fact in the worksheet it is more 40 50 or more then we replace the xlWhole  by xlPart in this instruction so it can find always the correct customer.

Set cCell = .Find(What:=myarr(i), LookIn:=xlValues, lookat:=xlPart, MatchCase:=False)



Below is the new code that you will find in the attached workbook.

Sub Tab_Clients()
Dim lr As Long, MaxRow As Long
Dim ws As Worksheet
Dim WSThis As Worksheet
Dim vcol, i As Integer
Dim icol As Long
Dim myarr As Variant
Dim title As String
Dim titlerow As Integer
Dim cCell As Range
Dim FirstAddress As String
Dim ThisYr As String, LastYr As String

'---> Disable Events
With Application
    .EnableEvents = False
    .ScreenUpdating = False
    .DisplayAlerts = False
End With

vcol = 1
Set ws = Sheets("Filtered from Prev Year")
LastYr = Format(Year(Now) - 1, "@")

Set WSThis = Sheets("Filtered from Current Year")
ThisYr = Format(Year(Now), "@")

lr = ws.Cells(ws.Rows.Count, vcol).End(xlUp).Row
title = "A1:BG1"
titlerow = ws.Range(title).Cells(1).Row
icol = ws.Columns.Count
ws.Cells(1, icol) = "Unique"
For i = 2 To lr
    On Error Resume Next
    If ws.Cells(i, vcol) <> "" And Application.WorksheetFunction.Match(ws.Cells(i, vcol), ws.Columns(icol), 0) = 0 Then
        ws.Cells(ws.Rows.Count, icol).End(xlUp).Offset(1) = Trim(Left(ws.Cells(i, vcol) & Space(30), 30))
    End If
Next

myarr = Application.WorksheetFunction.Transpose(ws.Columns(icol).SpecialCells(xlCellTypeConstants))
ws.Columns(icol).Clear
For i = 2 To UBound(myarr)
    ws.Range(title).AutoFilter field:=vcol, Criteria1:=myarr(i) & "*"
    If Not Evaluate("=ISREF('" & myarr(i) & "'!A1)") Then
        Sheets.Add(after:=Worksheets(Worksheets.Count)).Name = myarr(i) & ""
    Else
        Sheets(myarr(i) & "").Move after:=Worksheets(Worksheets.Count)
    End If
    If Sheets(myarr(i) & "").Range("A1") <> "Year" Then
        ws.Range("A" & titlerow & ":A" & lr).EntireRow.Copy Sheets(myarr(i) & "").Range("A1")
        Sheets(myarr(i) & "").Range("A1").EntireColumn.Insert
        Sheets(myarr(i) & "").Range("A1") = "Year"
        Sheets(myarr(i) & "").Range("A1").Offset(1, 0) = LastYr
    Else
        ws.Range("A" & titlerow & ":A" & lr).EntireRow.Copy Sheets(myarr(i) & "").Range("A1")
        Sheets(myarr(i) & "").Range("A1").Offset(1, 0).Insert xlShiftToRight
        Sheets(myarr(i) & "").Range("A1").Offset(1, 0) = LastYr
    End If
    MaxRow = Sheets(myarr(i) & "").Range("A" & Sheets(myarr(i) & "").Rows.Count).End(xlUp).Row + 1
    
    '---> Get Data from Last Year
    With WSThis.UsedRange
        Set cCell = .Find(What:=myarr(i), LookIn:=xlValues, lookat:=xlPart, MatchCase:=False)
        If Not cCell Is Nothing Then
            FirstAddress = cCell.Address
            Do
                cCell.EntireRow.Copy Sheets(myarr(i) & "").Range("A" & MaxRow)
                Sheets(myarr(i) & "").Range("A" & MaxRow).Insert xlShiftToRight
                Sheets(myarr(i) & "").Range("A" & MaxRow) = ThisYr
                MaxRow = MaxRow + 1
                Set cCell = .FindNext(cCell)
            Loop While Not cCell Is Nothing And cCell.Address <> FirstAddress
        End If
    End With
    
    '---> Columns Autofit
    Sheets(myarr(i) & "").Columns.AutoFit

    'CHARTCLIENT
Next

'---> Loop thru all clients and add tab for those not existing
lr = WSThis.Cells(WSThis.Rows.Count, vcol).End(xlUp).Row
For i = 2 To lr
    On Error Resume Next
    If WSThis.Cells(i, vcol) <> "" And Application.WorksheetFunction.Match(WSThis.Cells(i, vcol), ws.Columns(icol), 0) = 0 Then
        WSThis.Cells(WSThis.Rows.Count, icol).End(xlUp).Offset(1) = Trim(Left(WSThis.Cells(i, vcol) & Space(30), 30))
    End If
Next

myarr = Application.WorksheetFunction.Transpose(WSThis.Columns(icol).SpecialCells(xlCellTypeConstants))
WSThis.Columns(icol).Clear

For i = 2 To UBound(myarr)
    WSThis.Range(title).AutoFilter field:=vcol, Criteria1:=myarr(i) & "*"
    If Not Evaluate("=ISREF('" & myarr(i) & "'!A1)") Then
        Sheets.Add(after:=Worksheets(Worksheets.Count)).Name = myarr(i) & ""
    
        '---> Get Data only for the sheets that have This year and not last year
        If Sheets(myarr(i) & "").Range("A1") <> "Year" Then
            WSThis.Range("A" & titlerow & ":A" & lr).EntireRow.Copy Sheets(myarr(i) & "").Range("A1")
            Sheets(myarr(i) & "").Range("A1").EntireColumn.Insert
            Sheets(myarr(i) & "").Range("A1") = "Year"
            Sheets(myarr(i) & "").Range("A1").Offset(1, 0) = ThisYr
        Else
            ws.Range("A" & titlerow & ":A" & lr).EntireRow.Copy Sheets(myarr(i) & "").Range("A1")
            Sheets(myarr(i) & "").Range("A1").Offset(1, 0).Insert xlShiftToRight
            Sheets(myarr(i) & "").Range("A1").Offset(1, 0) = ThisYr
        End If
    End If

    '---> Columns Autofit
    Sheets(myarr(i) & "").Columns.AutoFit

Next i

WSThis.AutoFilterMode = False
ws.AutoFilterMode = False
ws.Activate

'---> Enable Events
With Application
    .EnableEvents = False
    .ScreenUpdating = False
    .DisplayAlerts = False
End With

MsgBox "Creation of Clients tab done.", vbExclamation
End Sub

Open in new window


Please try the attached file and advise your comments.
gowflow
Sales-TY-LY-V05.xlsm
0
jfrank85Author Commented:
thanks gowflow. and this includes the swap year functionality from the previous thread, right?
0
gowflowCommented:
yes
gowflow
0
jfrank85Author Commented:
gowflow, how can i get the clients to sort by name?

I tried to add:
ws.Sort.SortFields.Add Key:=Range("A1"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal ', Header:=xlYes


didn't do it.

Set ws = Sheets("Filtered from Prev Year")
ws.Sort.SortFields.Add Key:=Range("A1"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal ', Header:=xlYes
LastYr = Format(Year(Now) - 1, "@")

Set WSThis = Sheets("Filtered from Current Year")
WSThis.Sort.SortFields.Add Key:=Range("A1"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal ', Header:=xlYes
ThisYr = Format(Year(Now), "@")

Open in new window

0
gowflowCommented:
You want to sort this year and last year I guess ?
gowflow
0
gowflowCommented:
Basically it should be like this:

'---> Sort Last Year Based on Client Col A
ws.UsedRange.Sort Key1:=ws.Range("A1"), order1:=xlAscending, Header:=xlYes, MatchCase:=False

'---> Sort This Year Based on Client Col A
WSThis.UsedRange.Sort Key1:=WSThis.Range("A1"), order1:=xlAscending, Header:=xlYes, MatchCase:=False

Open in new window



Macro updated in the attached file.
gowlfow
Sales-TY-LY-V06.xlsm
0
jfrank85Author Commented:
thanks gowflow. that does do it, however when it comes to the tabs, they are not in alphabetical orders. if the client is new to 2015, they get added on the end.

any idea on how to re-org the tabs alphabetically as well? (tabs meaning worksheets) ?
0
gowflowCommented:
yes that is simple. I will add it now but please again and not for points but sake good order and sake follow-up by users on issues related to the main question please try to stay in the frame of the question and if need more then ask  related question or else threads will become quite long.

I will revert with the extra code to handle the sort.
gowflow
0
gowflowCommented:
Here is the solution that will Sort the new created tabs alphabetically (It will omit in the sort the main sheets Filtered from .... as we always want them first.)

Here is the code that has been incorporated in the attached workbook. The routine has a possibility to sort ascending or descending but we have fixed it to ascending without prompting the user for answer.

Private Sub Sort_Active_Book()
Dim I As Integer
Dim J As Integer
Dim iAnswer As VbMsgBoxResult
'
' Prompt the user as which direction they wish to
' sort the worksheets.
'
iAnswer = vbYes
'iAnswer = MsgBox("Sort Sheets in Ascending Order?" & Chr(10) _
  & "Clicking No will sort in Descending Order", _
  vbYesNoCancel + vbQuestion + vbDefaultButton1, "Sort Worksheets")
For I = 1 To Sheets.Count
    For J = 1 To Sheets.Count - 1
        
        ' Exclude certain sheets from Sorting
        If InStr(1, LCase(Sheets(J).Name), "filtered from") = 0 Then
        
            ' If the answer is Yes, then sort in ascending order.
            '
            If iAnswer = vbYes Then
                If UCase$(Sheets(J).Name) > UCase$(Sheets(J + 1).Name) Then
                   Sheets(J).Move after:=Sheets(J + 1)
                End If

            ' If the answer is No, then sort in descending order.
            '
            ElseIf iAnswer = vbNo Then
                If UCase$(Sheets(J).Name) < UCase$(Sheets(J + 1).Name) Then
                   Sheets(J).Move after:=Sheets(J + 1)
                End If
            End If
        End If
    Next J
Next I
End Sub

Open in new window


Pls check the attached workbook.
gowflow
Sales-TY-LY-V07.xlsm
0

Experts Exchange Solution brought to you by

Your issues matter to us.

Facing a tech roadblock? Get the help and guidance you need from experienced professionals who care. Ask your question anytime, anywhere, with no hassle.

Start your 7-day free trial
jfrank85Author Commented:
thanks!
0
gowflowCommented:
Welcome.
0
It's more than this solution.Get answers and train to solve all your tech problems - anytime, anywhere.Try it for free Edge Out The Competitionfor your dream job with proven skills and certifications.Get started today Stand Outas the employee with proven skills.Start learning today for free Move Your Career Forwardwith certification training in the latest technologies.Start your trial today
Microsoft Excel

From novice to tech pro — start learning today.

Question has a verified solution.

Are you are experiencing a similar issue? Get a personalized answer when you ask a related question.

Have a better answer? Share it in a comment.