Macro to create new workbook, with data being split into separate sheets based on criteria

[RobMolyneux]

Hi, I hope that someone can help as I'm really struggling and tripping myself up.

I receive data on a monthly basis which is always in the same format (number of columns) but can vary in data sets from 4,000 to 10,000 rows, and the data within is pretty variable.

I've written 4 basic macros which help to add labels to the data to allow me to filter it easily, but i now want to write another which will automatically process the data based on certain criteria being met.

I have 2 sheets in my current workbook

1) "Data" which is where i plan to copy and paste the data i receive in columns A-V
2) "Run" which is where i have created buttons with 4 macros embedded as a workflow that i can follow in order

the current 4 macros do the following:

1) add a new column W, with the heading "Category", and puts either "New", "Existing" or "Conversion" into column W for each row, based on what is contained in the data in column B

2) Add a new column X, with heading "Sub-Category", and puts either "House", "Bungalow", "Flat" or "Combo/Other" into column W, based on what is contained in the data in column B

3) add a new column Y, with heading "With Basement", and puts either "Yes" or "No" into column Y, based on what is contained in the data in column L

4) add a new column Z, with heading "Contact", and puts either "Yes" or "No" into column Y, based on what is contained in the data in column V


Within the "Run" sheet, I have added drop down boxes for selection by the user, which then combine as text in cell G33, which i would like to use as a automatic file name when i create the new workbook.



From here, I would like to write a macro to do the following;

When clicked, create a new workbook, automatically named as per the value in cell G33, with 3 worksheets (named "Leeds", "ContactABC" & "ExistingABC")

I then want those 3 worksheets to copy and past all rows and columns from the "Data" sheet based on the following criteria;


I want to copy data into "Leeds" if it meets the following criteria:

Column W = ("New" or "Conversion" ) AND column Z = "Yes"
OR
Column W = "Existing" AND Column Y = "Yes" AND Column Z = "Yes"


I want it to copy data into the "ContactABC" sheet based on the same criteria as above but Column Z = "No"


I then want to copy everything else into the "ExistingABC" sheet.



can this be done, and if so, what coding do i need.

many, many thanks in advance.

 

[RobMolyneux]

I should add, that I require the column headings in the "Data" sheet (row A) to also be copied into each of the 3 worksheets in the new workbook - ideally retaining the formatting from the "Data" sheet, but that is not really important if it causes extra work.

 

[AlphaFrog]

[color=darkblue]Sub[/color] Leads_Contact_Existing()
    
    [color=darkblue]Dim[/color] LastRow [color=darkblue]As[/color] [color=darkblue]Long[/color]
    [color=darkblue]Dim[/color] vData [color=darkblue]As[/color] [color=darkblue]Variant[/color]
    [color=darkblue]Dim[/color] vLeads [color=darkblue]As[/color] [color=darkblue]Variant[/color]
    [color=darkblue]Dim[/color] vContactABC [color=darkblue]As[/color] [color=darkblue]Variant[/color]
    [color=darkblue]Dim[/color] vExistingABC [color=darkblue]As[/color] [color=darkblue]Variant[/color]
    [color=darkblue]Dim[/color] r [color=darkblue]As[/color] [color=darkblue]Long[/color], c [color=darkblue]As[/color] [color=darkblue]Long[/color]
    [color=darkblue]Dim[/color] i [color=darkblue]As[/color] [color=darkblue]Long[/color], j [color=darkblue]As[/color] Long, k As Long
    
    i = 1: j = 1: k = 1
    
    [color=green]'Define data[/color]
    [color=darkblue]With[/color] ThisWorkbook.Sheets("Data")
        LastRow = .Cells.Find("*", , xlValues, , 1, 2).Row
        vData = .Range("A1:Z" & LastRow).Value    [color=green]'Read data to an array[/color]
    [color=darkblue]End[/color] [color=darkblue]With[/color]
    
    [color=green]'Declare output arrays for parsed data[/color]
    [color=darkblue]ReDim[/color] vLeads(1 [color=darkblue]To[/color] LastRow, 1 [color=darkblue]To[/color] [color=darkblue]UBound[/color](vData, 2))
    [color=darkblue]ReDim[/color] vContactABC(1 [color=darkblue]To[/color] LastRow, 1 [color=darkblue]To[/color] [color=darkblue]UBound[/color](vData, 2))
    [color=darkblue]ReDim[/color] vExistingABC(1 [color=darkblue]To[/color] LastRow, 1 [color=darkblue]To[/color] [color=darkblue]UBound[/color](vData, 2))
    
    [color=green]'Copy Headers to arrays[/color]
    [color=darkblue]For[/color] c = 1 [color=darkblue]To[/color] [color=darkblue]UBound[/color](vData, 2)
        vLeads(1, c) = vData(1, c)
        vContactABC(1, c) = vData(1, c)
        vExistingABC(1, c) = vData(1, c)
    [color=darkblue]Next[/color] c
    
    [color=green]'Parse Data to arrays[/color]
    [color=darkblue]For[/color] r = 2 [color=darkblue]To[/color] LastRow
    
        [color=darkblue]Select[/color] [color=darkblue]Case[/color] [color=darkblue]True[/color]
        
            [color=darkblue]Case[/color] (vData(r, 23) = "New" [color=darkblue]Or[/color] vData(r, 23) = "Conversion") And vData(r, 26) = "Yes", _
                 vData(r, 23) = "Existing" And vData(r, 25) = "Yes" And vData(r, 26) = "Yes"
                i = i + 1
                [color=darkblue]For[/color] c = 1 [color=darkblue]To[/color] [color=darkblue]UBound[/color](vData, 2)
                    vLeads(i, c) = vData(r, c)
                [color=darkblue]Next[/color] c
                
            [color=darkblue]Case[/color] (vData(r, 23) = "New" [color=darkblue]Or[/color] vData(r, 23) = "Conversion") And vData(r, 26) = "No", _
                 vData(r, 23) = "Existing" And vData(r, 25) = "Yes" And vData(r, 26) = "No"
                j = j + 1
                [color=darkblue]For[/color] c = 1 [color=darkblue]To[/color] [color=darkblue]UBound[/color](vData, 2)
                    vContactABC(j, c) = vData(r, c)
                [color=darkblue]Next[/color] c
                
            [color=darkblue]Case[/color] [color=darkblue]Else[/color]
                k = k + 1
                [color=darkblue]For[/color] c = 1 [color=darkblue]To[/color] [color=darkblue]UBound[/color](vData, 2)
                    vExistingABC(k, c) = vData(r, c)
                [color=darkblue]Next[/color] c
                
        [color=darkblue]End[/color] [color=darkblue]Select[/color]
        
    [color=darkblue]Next[/color] r
    
    [color=green]'New workbook[/color]
    Application.ScreenUpdating = [color=darkblue]False[/color]
    Application.SheetsInNewWorkbook = 3
    [color=darkblue]With[/color] Workbooks.Add
        [color=green]'Name sheets[/color]
        .Sheets(1).Name = "Leads"
        .Sheets(2).Name = "ContactABC"
        .Sheets(3).Name = "ExistingABC"
        [color=green]'Write parsed data[/color]
        .Sheets(1).Range("A1:Z" & i).Value = vLeads
        .Sheets(2).Range("A1:Z" & j).Value = vContactABC
        .Sheets(3).Range("A1:Z" & k).Value = vExistingABC
        [color=green]'Paste formats[/color]
        ThisWorkbook.Sheets("Data").Range("A:Z").Copy
        .Sheets(1).Range("A1").PasteSpecial xlPasteFormats
        .Sheets(1).Range("A1").PasteSpecial xlPasteColumnWidths
        .Sheets(2).Range("A1").PasteSpecial xlPasteFormats
        .Sheets(2).Range("A1").PasteSpecial xlPasteColumnWidths
        .Sheets(3).Range("A1").PasteSpecial xlPasteFormats
        .Sheets(3).Range("A1").PasteSpecial xlPasteColumnWidths
        [color=green]'Save[/color]
        .SaveAs ThisWorkbook.Path & "\" & ThisWorkbook.Sheets("Run").Range("G33").Value
[color=green]'        .Close False[/color]
    [color=darkblue]End[/color] [color=darkblue]With[/color]
    Application.ScreenUpdating = [color=darkblue]True[/color]
    
    [color=green]'Return to "Run" sheet[/color]
[color=green]'    Application.Goto ThisWorkbook.Sheets("Run").Range("A1")[/color]
    
[color=darkblue]End[/color] [color=darkblue]Sub[/color]

 

[RobMolyneux]

Hi AplhaFrog, that works like a dream, so thank you so much.

One question i have - the automatic saving of the file is putting it to my desktop, i assume that means it will go directly to the desktop if anyone is using it on a different machine? I'm assuming so, but would be helpful to know for sure.

Thanks again - I'm in awe of your ability.

 

[RobMolyneux]

It seems I may have spoken too soon...

I am now getting a run-time error 1004

which is a problem with the save file name. It still creates the new workbook, but just calls it Book1, or Book 2, etc.

nothing has changed from when it worked the first time to when it didnt work the next, other than i had a different value in Cell G33 (same structure, format, etc.) and even swapping it back to the one that worked the first time the error stays.

any advice?

 

[AlphaFrog]

It saves the new workbook to the same path that the macro workbook is saved to. Make sure your macro workbook has been saved at least once. If you tested this on a new macro workbook that has never been saved, then it has no path.

What is the error description?
When it errors, click the Debug button on the error dialog. What line of code is Highlighted?
What exactly is in sheet "Run" cell G33 ?

The new workbook gets a generic name of Book1, Book2 etc. in the title bar at the top until it is saved. Then it gets the filename. If your getting an error with saving, then the title bar name won't change until the save error gets fixed.

 

[RobMolyneux]

It turns out that I'm an imbecile, and had entered an additional row in the sheet during format changes, which meant it should have been looking up G34 now, rather than G33.

I've made the change and hey presto!

Thanks again.