Results 1 to 5 of 5

Split worksheet into multiples and add subtotals to each WS

Threaded View

johnboytweed Split worksheet into... 07-13-2012, 03:46 PM
mshale Re: Split worksheet into... 07-13-2012, 04:09 PM
johnboytweed Re: Split worksheet into... 07-13-2012, 04:24 PM
oeldere Re: Split worksheet into... 07-13-2012, 05:26 PM
oeldere Re: Split worksheet into... 07-13-2012, 05:28 PM
  1. #1
    Registered User
    Join Date
    07-13-2012
    Location
    Nashville, TN
    MS-Off Ver
    Excel 2010
    Posts
    8

    Split worksheet into multiples and add subtotals to each WS

    I have this macro that splits one worksheet into multiple worksheets based upon content from Column A.
    Does anyone know how to add subtotals to each worksheet either using this formula or by some other method that will work (other than actually going into each worksheet to do so).

    Sub Split_Worksheets()
    Dim rRange As Range, rCell As Range
    Dim wSheet As Worksheet
    Dim wSheetStart As Worksheet
    Dim strText As String
    
     Set wSheetStart = ActiveSheet
     wSheetStart.AutoFilterMode = False
     'Set a range variable to the correct item column
     Set rRange = Range("A1", Range("A65536").End(xlUp))
    
         'Delete any sheet called "UniqueList"
         'Turn off run time errors & delete alert
         On Error Resume Next
         Application.DisplayAlerts = False
         Worksheets("UniqueList").Delete
    
         'Add a sheet called "UniqueList"
         Worksheets.Add().Name = "UniqueList"
    
            'Filter the Set range so only a unique list is created
             With Worksheets("UniqueList")
                  rRange.AdvancedFilter xlFilterCopy, , _
                  Worksheets("UniqueList").Range("A1"), True
    
                  'Set a range variable to the unique list, less the heading.
                  Set rRange = .Range("A2", .Range("A65536").End(xlUp))
             End With
    
             On Error Resume Next
             With wSheetStart
                 For Each rCell In rRange
                   strText = rCell
                   .Range("A1").AutoFilter 1, strText
                     Worksheets(strText).Delete
                     'Add a sheet named as content of rCell
                     Worksheets.Add().Name = strText
                     'Copy the visible filtered range _
                     (default of Copy Method) and leave hidden rows
                     .UsedRange.Copy Destination:=ActiveSheet.Range("A1")
                     ActiveSheet.Cells.Columns.AutoFit
                 Next rCell
             End With
    
         With wSheetStart
             .AutoFilterMode = False
             .Activate
         End With
    
         On Error GoTo 0
         Application.DisplayAlerts = True
    End Sub
    Thank you
    Attached Files Attached Files

Thread Information

Users Browsing this Thread

There are currently 1 users browsing this thread. (0 members and 1 guests)

Tags for this Thread

Bookmarks

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts

Search Engine Friendly URLs by vBSEO 3.6.0 RC 1