Copied new sheets to retain page settings of copied sheet

[zakasnak]

This is the code I use to copy sheets by vendor to thier own sheet. I would like for each new sheet to retain the visual aspects of the original sheet (column size, zoom, filter, etc.). What would I need to change?

 Sub CopyToNewSheetsByGroup_2()
Dim strName As String, i As Integer
Dim UsedRng As Range, rng As Range, FRng As Range, R As Range, c As Range, sh As Worksheet
Dim HdrBoo As Boolean, HdrMsg As Variant, HdrRng As Range
Dim StartTime As Date, TmpSh As Worksheet, TmpRng As Range
Dim GroupIDs As String, ShName As String

    intResponse = MsgBox("This macro will create a worksheet for each unique group identifier" & vbCrLf & _
    "in the user-selected column. This may take a while to" & vbCrLf & _
    "process if there are a lot of groups. Continue?", vbOKCancel, "Separate By Groups")
    
    If intResponse = vbOK Then
        'Get used range for the sort
        Set UsedRng = ActiveSheet.UsedRange
        
        'Ask for column to base your search. If no range is selected procedure stopped
        On Error Resume Next 'set Rng will error if no range selected
        Set rng = Application.InputBox("Select column with Group ID's" & vbCrLf _
        & "Column must not contain Formulas.", "Pick a Column", , , , , , 8)
        If rng Is Nothing Or rng.Columns.Count > 1 Then 'exit if cancel was pressed or more than 1 column is selected
            MsgBox "Operation cancelled"
            Exit Sub
        End If
        
        'Ask if theres a header row. By default HdrBoo is false.
        HdrMsg = MsgBox("Do you have a header row?" & vbLf & _
            "Note: Must be the 1st row in worksheet", vbYesNo, "Header Row?")
        If HdrMsg = vbYes Then
            HdrBoo = True 'variable to indicate if a header is used
        End If
        
        'Start Timer
        StartTime = Timer
        
        'Turn off screen updating & calculation
        Application.ScreenUpdating = False
        Application.Calculation = xlCalculationManual
        
        On Error GoTo errorhandler
        'Filter unique values
        ActiveSheet.Columns(rng.Column).AdvancedFilter Action:=xlFilterInPlace, _
            CriteriaRange:=rng, Unique:=True
            
        'Copy unique values to a temporary sheet
        Set TmpSh = Worksheets.Add 'create temp sheet
        Sheets(rng.Parent.name).Activate 'return to original sheet
        Set rng = Range(rng.End(xlUp), rng.End(xlDown)) 'make sure entire column is selected
        
        rng.Copy TmpSh.Range("a1") 'copy unique items to temporary sheet
        TmpSh.Activate
        MyCount = TmpSh.Range([A1], [A1].End(xlDown)).Rows.Count
        
        If MyCount > 21 Then
            intResponse = MsgBox("There are more than 20 different groups." & vbCrLf & vbCrLf & _
            "This could take a while. Continue?", vbOKCancel, "Separate by Groups")
            If intResponse = vbCancel Then GoTo errorhandler
        End If
        
        'Set ranges for header (if applicable) and unique values
        TmpSh.Activate
        If HdrBoo = True Then
            Set HdrRng = Range("A1") '1st row in the range is the header
            Set TmpRng = Range("A2:A" & Range("A1").End(xlDown).Row) 'unique values
        Else
            Set TmpRng = Range("A1:A" & Range("A1").End(xlDown).Row) 'unique values
        End If
        
        Sheets(rng.Parent.name).Activate 'return to original sheet
        Application.CutCopyMode = False 'turn off copy mode
        ActiveSheet.ShowAllData 'remove Advanced Filter
        Set FRng = Range(rng.End(xlUp), rng.End(xlDown)) 'Set Full Range column for later use
        
        'Loop through each unique value to copy row to target in respective new sheets
        For Each c In TmpRng
            i = i + 1 'counter for sheet name
            Set sh = Worksheets.Add(after:=Sheets(Sheets.Count)) 'add a new sheet & name it
            ShName = TrimExcelSheetName(c.Value)
            If SheetExists(ShName) Then
                sh.name = ShName & Sheets.Count
            Else
                sh.name = ShName 'name sheet as string and counter number
            End If
            'Assign counter variable for row number to copy to
            'Also copy Header if True
            If HdrBoo = True Then
                cntr = Sheets(ShName).UsedRange.Rows.Count + 1
                'copy header row to target sheet
                Sheets(rng.Parent.name).Rows("1:1").Copy Sheets(ShName).Range("A1")
            Else
                cntr = Sheets(ShName).UsedRange.Rows.Count
            End If
            For Each R In FRng
                If R.Value = c Then
                    r2c = R.Row
                    Sheets(rng.Parent.name).Rows(r2c & ":" & r2c).Copy Sheets(ShName).Range("A" & cntr)
                    cntr = cntr + 1 'increment counter row number
                End If
            Next R
            sh.Cells.EntireColumn.autofit
        Next c
        
        'Turn back on screen updating & remove filter
        Application.ScreenUpdating = True
        Sheets(rng.Parent.name).Activate 'return to original sheet
        ActiveSheet.AutoFilterMode = False
        
        'Delete Temporary sheet
        Application.DisplayAlerts = False 'avoids delete confirmation message
        TmpSh.Delete
        Application.DisplayAlerts = True
        
        'Display the elapsed time
        MsgBox "The procedure took  " & Format(Timer - StartTime, "00.00") & "  seconds.", _
            vbInformation, "Operation Successfully Completed"
        End If
        ActiveSheet.AutoFilterMode = False
errorhandler:
    If Err <> 0 Then
        MsgBox Err.Number & ": " & Err.Description, , "Error Occurred"
        On Error GoTo 0
    End If
    Application.Calculation = xlCalculationAutomatic
    
End Sub

 

[zakasnak]

So I came up with this... & it worked the first time around on about the first 10 sheets, then it hangs.

    Columns("A:AA").Select
    Selection.Copy
    For Each ws In Worksheets
    ws.Activate
    Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
        SkipBlanks:=False, Transpose:=False
    Range("A1").Select
    Next ws
End Sub