Copy data from one tab and paste into a correspond worksheet

KP_SoCal
KP_SoCal used Ask the Experts™
on
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.
Example-Sheet.xlsx
Comment
Watch Question

Do more with

Expert Office
EXPERT OFFICE® is a registered trademark of EXPERTS EXCHANGE®
Top Expert 2008
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))
    Next
    
    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)
    Next
    
    .AutoFilterMode = False
End With

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

Open in new window


Thomas

Author

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

Do more with

Expert Office
Submit tech questions to Ask the Experts™ at any time to receive solutions, advice, and new ideas from leading industry professionals.

Start 7-Day Free Trial