Filter Range Copy Paste the Value and Create new Sheets

[LearningExcelVBA]

I have been trying to find an way to create multiple sheets using Specific Column data.

If Col"A" has multiple duplicate entries then filter single value create the new sheet using that value name, copy all the data and paste into newly added sheet.

I am unable to elaborate this thing in words and sorry for my poor English, i have attached an example workbook.

Where Sheet1 has data using Column A code will create multiple sheets. Your help will be much appreciated.

Sub CopyPartOfFilteredRange()
    Dim src As Worksheet
        Dim tgt As Worksheet
        Dim filterRange As Range
        Dim copyRange As Range
        Dim lastRow As Long
    
        Set src=ThisWorkbook.Sheets("Sheet1")
        Set tgt = ThisWorkbook.Sheets("Sheet8")
    
        src.AutoFilterMode = False
    
        lastRow = src.Range("A" & src.Rows.Count).End(xlUp).Row
    
        Set filterRange = src.Range("A1:A" & lastRow)
    
        Set copyRange = src.Range("A1:P" & lastRow)
    
        filterRange.AutoFilter field:=1, Criteria1:="CC"
    
        copyRange.SpecialCells(xlCellTypeVisible).Copy tgt.Range("A1")
    
    End Sub

[#2]

@LearningExcelVBA 

Sub SplitData()
    Dim src As Worksheet
    Dim trg As Worksheet
    Dim lastRow As Long
    Dim r As Long
    Dim col As New Collection
    Dim itm As Variant
    Application.ScreenUpdating = False
    Set src=Worksheets("Sheet1")
    src.AutoFilterMode = False
    lastRow = src.Range("A" & src.Rows.Count).End(xlUp).Row
    On Error Resume Next
    For r = 2 To lastRow
        itm = CStr(src.Range("A" & r).Value)
        col.Add Item:=itm, Key:=itm
    Next r
    On Error GoTo 0
    For Each itm In col
        Set trg = Nothing
        On Error Resume Next
        Set trg = Worksheets(itm)
        On Error GoTo 0
        If trg Is Nothing Then
            Set trg = Worksheets.Add(After:=Worksheets(Worksheets.Count))
            trg.Name = itm
        Else
            trg.UsedRange.ClearContents
        End If
        src.UsedRange.AutoFilter Field:=1, Criteria1:=itm
        src.UsedRange.Copy Destination:=trg.Range("A1")
    Next itm
    src.AutoFilterMode = False
    Application.CutCopyMode = False
    Application.ScreenUpdating = True
End Sub

[#3]

@Hans Vogelaar  

I have been receiving an error type mismatch because i have some strings with that signs | and there are 400+ unique values in Column A

[#4 · Accepted solution]

@LearningExcelVBA 

You should always post a relevant example instead of one simplified too far.

| is allowed in a sheet name, but the following characters aren't: \ , / , * , ? , : , [ , ].

To get rid of those:

Sub SplitData()
    Dim src As Worksheet
    Dim trg As Worksheet
    Dim lastRow As Long
    Dim r As Long
    Dim col As New Collection
    Dim itm As Variant
    Dim c As Variant
    Application.ScreenUpdating = False
    Set src=Worksheets("Sheet1")
    src.AutoFilterMode = False
    lastRow = src.Range("A" & src.Rows.Count).End(xlUp).Row
    On Error Resume Next
    For r = 2 To lastRow
        itm = CStr(src.Range("A" & r).Value)
        col.Add Item:=itm, Key:=itm
    Next r
    On Error GoTo 0
    For Each itm In col
        For Each c In Array("\", "/", "*", "?", ":", "[", "]")
            itm = Replace(itm, c, "_")
        Next c
        Set trg = Nothing
        On Error Resume Next
        Set trg = Worksheets(itm)
        On Error GoTo 0
        If trg Is Nothing Then
            Set trg = Worksheets.Add(After:=Worksheets(Worksheets.Count))
            trg.Name = itm
        Else
            trg.UsedRange.ClearContents
        End If
        src.UsedRange.AutoFilter Field:=1, Criteria1:=itm
        src.UsedRange.Copy Destination:=trg.Range("A1")
    Next itm
    src.AutoFilterMode = False
    Application.CutCopyMode = False
    Application.ScreenUpdating = True
End Sub

[#5]

I apologize for the mistakes but now there is new problem that is name is exceeding more characters than 31. How to keep the limit to 31 character if it is long.

[#6]

@LearningExcelVBA 

The following will truncate the names to 31 characters. You will have a problem if there are names that differ only beyond the 31st character. For example thisisaridiculouslylongnamenumberone and thisisaridiculouslylongnamenumbertwo. Both will be truncated to thisisaridiculouslylongnamenumb.

Sub SplitData()
    Dim src As Worksheet
    Dim trg As Worksheet
    Dim lastRow As Long
    Dim r As Long
    Dim col As New Collection
    Dim itm As Variant
    Dim c As Variant
    Application.ScreenUpdating = False
    Set src=Worksheets("Sheet1")
    src.AutoFilterMode = False
    lastRow = src.Range("A" & src.Rows.Count).End(xlUp).Row
    On Error Resume Next
    For r = 2 To lastRow
        itm = CStr(src.Range("A" & r).Value)
        col.Add Item:=itm, Key:=itm
    Next r
    On Error GoTo 0
    For Each itm In col
        For Each c In Array("\", "/", "*", "?", ":", "[", "]")
            itm = Replace(itm, c, "_")
        Next c
        itm = Left(itm, 31)
        Set trg = Nothing
        On Error Resume Next
        Set trg = Worksheets(itm)
        On Error GoTo 0
        If trg Is Nothing Then
            Set trg = Worksheets.Add(After:=Worksheets(Worksheets.Count))
            trg.Name = itm
        Else
            trg.UsedRange.ClearContents
        End If
        src.UsedRange.AutoFilter Field:=1, Criteria1:=itm
        src.UsedRange.Copy Destination:=trg.Range("A1")
    Next itm
    src.AutoFilterMode = False
    Application.CutCopyMode = False
    Application.ScreenUpdating = True
End Sub

[#7]

Sir thank you very much