creating individual databases from smaller ones

Hey everyone, I posted in the other forum and just wanted to link it in here too to see if anyone has any wisdom they could share with me. The question/situation is explaining in the first post on the link.

thank you very much!

http://www.excelforum.com/excel-gene...51#post2854751

**I would like to add also that I will be making this workbook but it will be someone else who will be using it in the future. I will not be present so, ideally, whatever function I end up using can be easily repeated by someone without the same expertise.

Probably you get the solution with the link below.

http://www.excelforum.com/excel-gene...o-each-ws.html

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