Macro to copy rows to new workbook & separate worksheets

Hello

Can anyone help me with a macro for the following problem.

I have a master sheet with hundreds of rows. When the category in column A (department name) changes, I want to export these rows into a new workbook which will be called after that department.

eg. SALES.XLS

I have seen some great posts already on this site which shows me how to do this.(e.g. http://www.excelforum.com/excel-prog...e-in-data.html)

However I have another requirement which complicates this.

There is another column in the master sheet which lists dates in dd/mm/yy format. Once the rows are exported to the new workbooks, I need these rows to further separate into four different worksheets, one for each quarter.

Q1,Q2,Q3,Q4

There are perhaps a dozen differnt departments in the master sheet (HR, IT, Sales, etc)


Once the macro is run, the master sheet should still exist, but now there will be 12 new workbooks named after the department they contain, all with four worksheets, one for each quarter.

Finally, if possible, they should all be saved to a new location within a folder called after the department

e.g. S:\\MIS data\Sales\Sales.xls

Any help would be much appreciated.

Martin

Hello malachi,

Welcome to the Forum!

It would be a big help if you could two things: Post a copy of the master workbook and define the dates or months for each quarter. Once you have done that, it will be easier to provide you with a solution.

'SHEET1 TO MANY WORKBOOKS

I have a macro that may be "ready to use" for parsing rows of data from one sheet to many workbooks named for the same values.

Sheet1 to Many Workbooks

I've edited the SAVE part to use your naming convention, just make sure those directories already exist and they will save into there. The original code on the website added today's date to the named file, you can add that back in if you wish.


Since this macro is good for getting the one worksheet out to many workbooks, I wrote a small routine that would then split out that new workbook to multiple worksheets, it's called ParseQuarters.

Here are the two macros:

code removed...see below

You didn't indicate to me where the type mismatch occurred for you, and when I ran the main macro it worked OK.

The second macro you failed to edit the DateCol variable at the top to the proper column with dates for the parsing.

I decided to restructure the new macro a little so you send the DateCol a value in the CALL command from the main macro, that should make it a little more obvious what is needed. I also corrected some filtering errors I spotted in the second macro now that I had an actual dataset to test it on.

Please remove all code from the ThisWorkbook module. These macros do not belong in there.

Click on Insert > Module and put these into the standard module that appears.

Option Explicit

Sub ParseItems()
'Jerry Beaucaire  (4/22/2010)
'Based on selected column, data is filtered to individual workbooks
'workbooks are named for the parse value
Dim LR As Long, Itm As Long, MyCount As Long, vCol As Long
Dim ws As Worksheet, MyArr As Variant, vTitles As String, SvPath As String

Application.ScreenUpdating = False

'Column to evaluate from, column A = 1, B = 2, etc.
   vCol = 1
 
'Sheet with data in it
   Set ws = Sheets("MIS")

'Path to save files into, remember the final \
    SvPath = "H:\2010\"

'Range where titles are across top of data, as string, data MUST
'have titles in this row, edit to suit your titles locale
    vTitles = "A1:Z1"
   
'Spot bottom row of data
   LR = ws.Cells(ws.Rows.Count, vCol).End(xlUp).Row

'Get a temporary list of unique values from column A
    ws.Columns(vCol).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=ws.Range("EE1"), Unique:=True

'Sort the temporary list
    ws.Columns("EE:EE").Sort Key1:=ws.Range("EE2"), Order1:=xlAscending, Header:=xlYes, _
       OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, DataOption1:=xlSortNormal

'Put list into an array for looping (values cannot be the result of formulas, must be constants)
    MyArr = Application.WorksheetFunction.Transpose(ws.Range("EE2:EE" & Rows.Count).SpecialCells(xlCellTypeConstants))

'clear temporary worksheet list
    ws.Range("EE:EE").Clear

'Turn on the autofilter, one column only is all that is needed
    ws.Range(vTitles).AutoFilter

'Loop through list one value at a time
    For Itm = 1 To UBound(MyArr)
        ws.Range(vTitles).AutoFilter Field:=vCol, Criteria1:=MyArr(Itm)
        
        ws.Range("A1:A" & LR).EntireRow.Copy
        Worksheets.Add
        Range("A1").PasteSpecial xlPasteAll
        ActiveSheet.Move
        Cells.Columns.AutoFit
            
        MyCount = MyCount + Range("A" & Rows.Count).End(xlUp).Row - 1
            
        Call ParseQuarters(6)    'this will parse the new worksheet into quarters
                                 'by the date in the column given
                
        ActiveWorkbook.SaveAs SvPath & MyArr(Itm) & "\" & MyArr(Itm), xlNormal
        ActiveWorkbook.Close False
        
        ws.Range(vTitles).AutoFilter Field:=vCol
    Next Itm

'Cleanup
    ws.AutoFilterMode = False
    MsgBox "Rows with data: " & (LR - 1) & vbLf & "Rows copied to other sheets: " & MyCount & vbLf & "Hope they match!!"
    Application.ScreenUpdating = True
End Sub

Sub ParseQuarters(DateCol As Long)
Dim QtrYr As Long:      QtrYr = Year(Cells(2, DateCol))
Dim LR As Long
Application.DisplayAlerts = False

With ActiveSheet
    .Rows(1).AutoFilter
    .Rows(1).AutoFilter Field:=DateCol, Criteria1:="<1/4/" & QtrYr
    Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = "Q1"
    LR = .Range("A" & .Rows.Count).End(xlUp).Row
    .Range("A1:A" & LR).EntireRow.Copy Range("A1")
    Columns.AutoFit
    
    .Rows(1).AutoFilter Field:=DateCol, Criteria1:=">=1/4/" & QtrYr, _
            Operator:=xlAnd, Criteria2:="<7/1/" & QtrYr
    Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = "Q2"
    LR = .Range("A" & .Rows.Count).End(xlUp).Row
    .Range("A1:A" & LR).EntireRow.Copy Range("A1")
    Columns.AutoFit
    
    .Rows(1).AutoFilter Field:=DateCol, Criteria1:=">=7/1/" & QtrYr, _
            Operator:=xlAnd, Criteria2:="<10/1/" & QtrYr
    Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = "Q3"
    LR = .Range("A" & .Rows.Count).End(xlUp).Row
    .Range("A1:A" & LR).EntireRow.Copy Range("A1")
    Columns.AutoFit
    
    .Rows(1).AutoFilter Field:=DateCol, Criteria1:=">=10/1/" & QtrYr, _
            Operator:=xlAnd, Criteria2:="<1/1/" & QtrYr + 1
    Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = "Q4"
    LR = .Range("A" & .Rows.Count).End(xlUp).Row
    .Range("A1:A" & LR).EntireRow.Copy Range("A1")
    Columns.AutoFit
    
    .Delete
End With

End Sub

If that takes care of your need, please click EDIT in your original post, click GO ADVANCED and set the PREFIX box to SOLVED.