Copy data from one tab and paste into a correspond worksheet

I’m trying to come up with a sub routine that will copy the data from the ‘dataSheet’ tab and paste it into its corresponding ‘Zone’ tab.  You’ll notice that the first column in the datasheet has names that correspond to a particular ‘Zone’ worksheet.

If you look at my attached file, you’ll get the basic idea of what I’m trying to accomplish.  I need this routine to be dynamic in that I could have a different number of “Zone” tabs from month to month.
Who is Participating?
nutschConnect With a Mentor Commented:
Something like this?

Sub SplitListIntoZones()
'split list into individual worksheets
Dim lLoop As Long, arrData As Variant
Dim shtData As Worksheet, lgCol As Long, rgSel As Range
Dim cUnique As New Collection, shtDest As Worksheet
Const blTitles As Boolean = True                    'true if the data has titles, false otherwise
Const sColumn As String = "A"                       'Which column should the list be split on

Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.DisplayAlerts = False

lgCol = Cells(1, sColumn).Column
Set rgSel = Cells(1, 1).CurrentRegion

Set shtData = ActiveSheet

With shtData
    'load the column into an array for faster processing
    arrData = .Range(.Cells(1, sColumn), .Cells(.Rows.Count, sColumn).End(xlUp)).Value
    'load the array content in a collection, to keep individual values only
    On Error Resume Next
    For lLoop = LBound(arrData, 1) To UBound(arrData, 1)
        cUnique.Add arrData(lLoop, 1), CStr(arrData(lLoop, 1))
    On Error GoTo 0
    'for each individual value, filter the list, copy the results to a new worksheet
    For lLoop = 1 To cUnique.Count
        .AutoFilterMode = False
        rgSel.CurrentRegion.AutoFilter Field:=lgCol - rgSel.CurrentRegion.Column + 1, Criteria1:=cUnique(lLoop)
        Set shtDest = Sheets.Add
        shtDest.Name = cUnique(lLoop)
        rgSel.CurrentRegion.Copy shtDest.Cells(4, 2)
    .AutoFilterMode = False
End With

Application.ScreenUpdating = True 'reenable ScreenUpdating
Application.Calculation = xlCalculationAutomatic
Application.DisplayAlerts = True
End Sub

Open in new window

KP_SoCalAuthor Commented:
Thank you!  This is exactly what I needed!  Also, I really appreciate the explanation comments in the code. ;-)
Question has a verified solution.

Are you are experiencing a similar issue? Get a personalized answer when you ask a related question.

Have a better answer? Share it in a comment.

All Courses

From novice to tech pro — start learning today.