Forum Discussion

Copper Contributor

Nov 23, 2021

Solved

Filter Range Copy Paste the Value and Create new Sheets

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

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

6 Replies

HansVogelaar

MVP

Nov 24, 2021

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

LearningExcelVBA

Copper Contributor

Nov 24, 2021

HansVogelaar

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

HansVogelaar

MVP

Nov 24, 2021

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