Naming Worksheets based on column values.

[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, as I have the maximum worksheet set length to 31 which Excel accepts. How ever as some of the values in column A are the exact same when you compress them to 31 characters, Excel is throwing an error saying that the name is already taken. - Is it possible to say reduce the characters to 28 in these instances and then just add "_1,2,3" for each instance that this occurs?

Thanks in Advnce



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 = Left(ws.Cells(x, c).Value 31)

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

 

[Alex Blakenburg]

You have posted a number of times now. Can you please post your code using the VBA button on the toolbar.
You are more likely to get a response if you use the tag as it wil be far easier to read and to work with when we copy it into our test sheet.

Someone might know a more streamlined way of doing this but this should do what you are asking for.
Note: As it stands it will not delete sheets from a previous run that do not have data in the current run or if the sheet name was a duplicate last time and not this or vice versa (this will cause the name to not match the previous run's name)

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
    
    Dim rngShtNames As Range
    Dim arrShtNames As Variant
    Dim Name31 As String
    Dim iPrevious31 As Long
    Set rngShtNames = ws.Cells(1, c).Resize(r1)
    rngShtNames.Sort Key1:=ws.Cells(1, c), Header:=xlYes
    
    '-----------------------------------------------------
    'Check if 31 character name creates duplicate names
    'if it does use only the first 28 characters and add
    'a sequential no suffix preceded by "_"
    '-----------------------------------------------------
    Set rngShtNames = rngShtNames.Resize(, 4)
    arrShtNames = rngShtNames
            
    Dim dict31Char As Object, dictKey As String
    Set dict31Char = CreateObject("Scripting.dictionary")
    
    For x = 2 To r1
        Name31 = Left(arrShtNames(x, 1), 31)
        arrShtNames(x, 2) = Name31
        dictKey = Name31

        If Not dict31Char.exists(dictKey) Then
            dict31Char(dictKey) = x
            arrShtNames(x, 3) = 0
        Else
            iPrevious31 = dict31Char(dictKey)
            If arrShtNames(iPrevious31, 3) = 0 Then
                arrShtNames(iPrevious31, 3) = 1
            End If
                arrShtNames(x, 3) = arrShtNames(iPrevious31, 3) + 1
                dict31Char(dictKey) = x
        End If
    Next x
    
    For x = 2 To r1
        If arrShtNames(x, 3) <> 0 Then
            arrShtNames(x, 4) = Left(arrShtNames(x, 1), 28) & "_" & arrShtNames(x, 3)
        Else
            arrShtNames(x, 4) = Left(arrShtNames(x, 1), 31)
        End If
    Next x
    
    ws.AutoFilterMode = False

    Application.DisplayAlerts = False
    On Error Resume Next
    For x = 2 To r1
        Worksheets(arrShtNames(x, 4)).Delete
    Next
    On Error GoTo 0
    Application.DisplayAlerts = True
    
    For x = 2 To r1
        ws.Range(ws.Cells(1, sCol), ws.Cells(r, sCol)).AutoFilter Field:=1, Criteria1:=arrShtNames(x, 1)
        Set ws1 = Worksheets.Add(after:=Worksheets(Worksheets.Count))
        ws1.Name = arrShtNames(x, 4)
        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