Solved

Copy data from one tab and paste into a correspond worksheet

Posted on 2014-03-03
2
308 Views
Last Modified: 2014-03-03
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
0
Comment
Question by:KP_SoCal
2 Comments
 
LVL 39

Accepted Solution

by:
nutsch earned 500 total points
ID: 39902047
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
0
 

Author Closing Comment

by:KP_SoCal
ID: 39902211
Thank you!  This is exactly what I needed!  Also, I really appreciate the explanation comments in the code. ;-)
0

Featured Post

Ransomware: The New Cyber Threat & How to Stop It

This infographic explains ransomware, type of malware that blocks access to your files or your systems and holds them hostage until a ransom is paid. It also examines the different types of ransomware and explains what you can do to thwart this sinister online threat.  

Question has a verified solution.

If you are experiencing a similar issue, please ask a related question

A simple tool to export all objects of two Access files as text and compare it with Meld, a free diff tool.
It’s been over a month into 2017, and there is already a sophisticated Gmail phishing email making it rounds. New techniques and tactics, have given hackers a way to authentically impersonate your contacts.How it Works The attack works by targeti…
This Micro Tutorial will demonstrate in Microsoft Excel how to add style and sexy appeal to horizontal bar charts.
Excel styles will make formatting consistent and let you apply and change formatting faster. In this tutorial, you'll learn how to use Excel's built-in styles, how to modify styles, and how to create your own. You'll also learn how to use your custo…

777 members asked questions and received personalized solutions in the past 7 days.

Join the community of 500,000 technology professionals and ask your questions.

Join & Ask a Question