VBA:copy rows based on criteria to a new sheet/file.

[lakersbg]

Dear Excel pros,
Unfortunately I don't know much about the VBA language so I'll appreciate it if you could help me on the following macro:
Each month I get two files with data which I have to reconcile (find for each customer account (let's say each unique value in column A) the rows that are missing in one of the two files. So, I want to do a macro which would help me, once I've put the data into one sheet and sorted on Column A, to copy the rows containing each unique value in A (each customer) into a new sheet/file. After that I can easily delete the duplicate rows and see what is missing from one of the files.
I found a macro that more or less suits me, but I need to make it repeat itself for each unique value in Column A (or from a list of values if it will be easier).
Here is the macros that I found, you can modify it to suite my purpose. Big thank you in advance!
Best Regards,
Lakersbg

Sub Extract_Data()
'this macro assumes that your first row of data is a header row.
'will copy a row from one worksheet, to another blank workbook
'IF there is a 0 in column N
'Variables used by the macro
Application.ScreenUpdating = False
Dim FilterCriteria
Dim CurrentFileName As String
Dim NewFileName As String

'Get the current file's name
CurrentFileName = ActiveWorkbook.Name
'Select Range
'(note you can change this to meet your requirements)
Range("A1:AS3000").Select
'Apply Autofilter
Selection.AutoFilter
FilterCriteria = Range("Sheet2!A1").Value
'NOTE - this filter is on column A (field:=1), to change
'to a different column you need to change the field number
Selection.AutoFilter field:=1, Criteria1:=FilterCriteria
'Select the visible cells (the filtered data)
Selection.SpecialCells(xlCellTypeVisible).Select
'Copy the cells
Selection.Copy
'Open a new file
Workbooks.Add Template:="Workbook"
'Get this file's name
NewFileName = ActiveWorkbook.Name
'Make sure you are in cell A1
Range("A1").Select
'Paste the copied cells
ActiveSheet.Paste
'Clear the clipboard contents
Application.CutCopyMode = False
'Go back to the original file
Workbooks(CurrentFileName).Activate
'Clear the autofilter
Selection.AutoFilter field:=1
'Take the Autofilter off
Selection.AutoFilter
'Go to A1
Range("A1").Select
Application.ScreenUpdating = True
End Sub

 

[Alfaia]

Hi Alphafrog,

I ended up managing to do what I wanted but I am now stuck at something else as what I hope to achieve in the end is far more intricate than just this bit. You praobably can figure outa way to this better than I can.

What I want to do is the following: from an exsting workbook with several sheets I want to merge it into a new workbook and break it all down by a filter it by a given criteria e.g.

I have a file with a sheet with addresses, a sheet with names and buys and sells, a sheet with inventory at beggining of year, and another one with inventory at the end of the year and I want to use this to build a file that picks up this information from the different sheets to the new workbook separtaed by names so the end result would be a sheet for each name that displayed the corresponding address at the top and then a summary with the inventory at beggining of the year vs the inventory at the end of the year and below that each list of purchases and sales divided by item. (not easy...

Hi Alfaia and welcome to the forum.

It's hard to see the code you posted because of some formatting glitch I guess.

Try the code in Post #18. I think it's does what you're asking. Start with that and see what happens.

 

[Alfaia]

Hi Alphafrog,

I ended up managing to do what I wanted but I am now stuck at something else as what I hope to achieve in the end is far more intricate than just this bit. You praobably can figure outa way to this better than I can.

What I want to do is the following: from an exsting workbook with several sheets I want to merge it into a new workbook and break it all down by a filter it by a given criteria e.g.

I have a file with a sheet with addresses, a sheet with names and buys and sells, a sheet with inventory at beggining of year, and another one with inventory at the end of the year and I want to use this to build a file that picks up this information from the different sheets to the new workbook separtaed by names so the end result would be a sheet for each name that displayed the corresponding address at the top and then a summary with the inventory at beggining of the year vs the inventory at the end of the year and below that each list of purchases and sales divided by item. (not easy...)

At the moment I'm stuck in how to break down and copy the data from the base file to the existing sheet based on two criteria to list the purchases and sales by item. I have a worksheet (buys and sells) and in column D the name and in column F the item, so Based on a mix of your code and some that I have been doing I managet form this to create the new workbook and a sheet per each name but i still wanted the data going into that shhet to separated and divided by item.

I have john that has bough and sold apples and pears and oranges and I wanted that listed as header apples and then purchases and sales, then below a new header for pears and purchases and sales and then the same for oranges and so on..

Any suggestions? I'still browsing away for solutions as when i tried to replicate this using excel and then checking the VBA code i'm not getting far...

 

[Picola]

Hi AlphaFrog,

I'm a newbie on this forum and also into the VBA world ... .

I'm actually using your below code which works perfectly well. How should I modify the code if I want to save each unique values into new worksheets (of the active workbook) instead of new workbooks ? I tried to do it myself but I get a runtime error 13.

May I ask you some help ?

Thanks a lot, very appreciated,

Picola.

Hi and welcome to the forum. Also, well done on first searching for a solution.

This will save each unique-value's row to a new workbook and save the workbook to the same location as the the source macro workbook. The file names will be the cell value and the current date. Change the red date format to suit.

[COLOR=darkblue]Sub[/COLOR] Extract_All_Data_To_New_Workbook()
    
    [COLOR=green]'this macro assumes that your first row of data is a header row.[/COLOR]
    [COLOR=green]'will copy all filtered rows from one worksheet, to another blank workbook[/COLOR]
    [COLOR=green]'each unique filtered value will be copied to it's own workbook[/COLOR]
    
    [COLOR=green]'Variables used by the macro[/COLOR]
    [COLOR=darkblue]Dim[/COLOR] wbDest [COLOR=darkblue]As[/COLOR] Workbook
    [COLOR=darkblue]Dim[/COLOR] rngFilter [COLOR=darkblue]As[/COLOR] Range, rngUniques [COLOR=darkblue]As[/COLOR] Range
    [COLOR=darkblue]Dim[/COLOR] cell [COLOR=darkblue]As[/COLOR] Range
    
    [COLOR=green]' Set the filter range (from A1 to the last used cell in column A)[/COLOR]
    [COLOR=green]'(Note: you can change this to meet your requirements)[/COLOR]
    [COLOR=darkblue]Set[/COLOR] rngFilter = Range("A1", Range("A" & Rows.Count).End(xlUp))
    
    Application.ScreenUpdating = [COLOR=darkblue]False[/COLOR]
    
    [COLOR=darkblue]With[/COLOR] rngFilter
        
        [COLOR=green]' Filter column A to show only one of each item (uniques) in column A[/COLOR]
        .AdvancedFilter Action:=xlFilterInPlace, Unique:=[COLOR=darkblue]True[/COLOR]
        
        [COLOR=green]' Set a variable to the Unique values[/COLOR]
        [COLOR=darkblue]Set[/COLOR] rngUniques = Range("A2", Range("A" & Rows.Count).End(xlUp)).SpecialCells(xlCellTypeVisible)
        
        [COLOR=green]' Clear the filter[/COLOR]
        ActiveSheet.ShowAllData
        
    [COLOR=darkblue]End[/COLOR] [COLOR=darkblue]With[/COLOR]
    
    [COLOR=green]' Filter, Copy, and Paste each unique to its own new workbook[/COLOR]
    [COLOR=darkblue]For[/COLOR] [COLOR=darkblue]Each[/COLOR] cell [COLOR=darkblue]In[/COLOR] rngUniques
    
        [COLOR=green]' Create a new workbook for each unique value[/COLOR]
        [COLOR=darkblue]Set[/COLOR] wbDest = Workbooks.Add(xlWBATWorksheet)
                
        [COLOR=green]'NOTE - this filter is on column A (field:=1), to change[/COLOR]
        [COLOR=green]'to a different column you need to change the field number[/COLOR]
        rngFilter.AutoFilter Field:=1, Criteria1:=cell.Value
        
        [COLOR=green]' Copy and paste the filtered data to its new workbook[/COLOR]
        rngFilter.EntireRow.Copy
        [COLOR=darkblue]With[/COLOR] wbDest.Sheets(1).Range("A1")
            .PasteSpecial xlPasteColumnWidths           [COLOR=green]'Paste column widths[/COLOR]
            .PasteSpecial xlPasteValuesAndNumberFormats [COLOR=green]'Paste values[/COLOR]
        [COLOR=darkblue]End[/COLOR] [COLOR=darkblue]With[/COLOR]
        Application.CutCopyMode = [COLOR=darkblue]True[/COLOR]
        
        [COLOR=green]' Name the destination sheet[/COLOR]
        wbDest.Sheets(1).Name = cell.Value
        
        [COLOR=green]'Save the destination workbook and close[/COLOR]
        wbDest.SaveAs ThisWorkbook.Path & Application.PathSeparator & _
            cell.Value & " " & Format(Date, [COLOR=#ff0000]"mmm_dd_yyyy"[/COLOR])
[COLOR=green]'        wbDest.Close False 'Close the new workbook[/COLOR]
        
    [COLOR=darkblue]Next[/COLOR] cell
    
    rngFilter.Parent.AutoFilterMode = [COLOR=darkblue]False[/COLOR]
    Application.ScreenUpdating = [COLOR=darkblue]True[/COLOR]
    
[COLOR=darkblue]End[/COLOR] [COLOR=darkblue]Sub[/COLOR]

 

[AlphaFrog]

Hi Picola and welcome. Try this...

[color=darkblue]Sub[/color] Extract_All_Data_To_New_Worksheets()
    
    [color=green]'this macro assumes that your first row of data is a header row.[/color]
    [color=green]'will copy all filtered rows from one worksheet, to new worksheets in the same workbook[/color]
    [color=green]'each unique filtered value will be copied to it's own new sheet[/color]
    
    [color=green]'Variables used by the macro[/color]
    [color=darkblue]Dim[/color] wsDest [color=darkblue]As[/color] Worksheet
    [color=darkblue]Dim[/color] rngFilter [color=darkblue]As[/color] Range, rngUniques [color=darkblue]As[/color] Range
    [color=darkblue]Dim[/color] cell [color=darkblue]As[/color] Range
    
    [color=green]' Set the filter range (from A1 to the last used cell in column A)[/color]
    [color=green]'(Note: you can change this to meet your requirements)[/color]
    [color=darkblue]Set[/color] rngFilter = Range("A1", Range("A" & Rows.Count).End(xlUp))
    
    Application.ScreenUpdating = [color=darkblue]False[/color]
    
    [color=darkblue]With[/color] rngFilter
        
        [color=green]' Filter column A to show only one of each item (uniques) in column A[/color]
        .AdvancedFilter Action:=xlFilterInPlace, Unique:=[color=darkblue]True[/color]
        
        [color=green]' Set a variable to the Unique values[/color]
        [color=darkblue]Set[/color] rngUniques = Range("A2", Range("A" & Rows.Count).End(xlUp)).SpecialCells(xlCellTypeVisible)
        
        [color=green]' Clear the filter[/color]
        ActiveSheet.ShowAllData
        
    [color=darkblue]End[/color] [color=darkblue]With[/color]
    
    [color=green]' Filter, Copy, and Paste each unique to its own new worksheet[/color]
    [color=darkblue]For[/color] [color=darkblue]Each[/color] cell [color=darkblue]In[/color] rngUniques
    
        [color=darkblue]If[/color] cell.Value <> "" [color=darkblue]Then[/color]
    
            [color=green]' Create a new worksheet for each unique value[/color]
            [color=darkblue]Set[/color] wsDest = Sheets.Add(After:=Sheets(Sheets.Count))
                    
            [color=green]'NOTE - this filter is on column A (field:=1), to change[/color]
            [color=green]'to a different column you need to change the field number[/color]
            rngFilter.AutoFilter Field:=1, Criteria1:=cell.Value
            
            [color=green]' Copy and paste the filtered data to its new worksheet[/color]
            rngFilter.EntireRow.Copy
            [color=darkblue]With[/color] wsDest.Range("A1")
                .PasteSpecial xlPasteColumnWidths           [color=green]'Paste column widths[/color]
                .PasteSpecial xlPasteValuesAndNumberFormats [color=green]'Paste values[/color]
            [color=darkblue]End[/color] [color=darkblue]With[/color]
            Application.CutCopyMode = [color=darkblue]True[/color]
            
            [color=green]' Name the destination sheet[/color]
            [color=darkblue]If[/color] [color=darkblue]Not[/color] Evaluate("ISREF('" & cell.Value & "'!A1)") Then  [color=green]'Test if worksheet name already exists[/color]
                wsDest.Name = cell.Value    [color=green]'Name sheet[/color]
            [color=darkblue]End[/color] [color=darkblue]If[/color]
        
        [color=darkblue]End[/color] [color=darkblue]If[/color]
        
    [color=darkblue]Next[/color] cell
    
    rngFilter.Parent.AutoFilterMode = [color=darkblue]False[/color]
    Application.ScreenUpdating = [color=darkblue]True[/color]
    
[color=darkblue]End[/color] [color=darkblue]Sub[/color]

 

[Picola]

Hi AlphaFrog,

Thanks a lot for your help, works very well !

Let me ask you another one, what is the code to select all worksheets in a workbook, except sheets(1) ?

In fact I would like to add lines, columns, etc. to all worksheets except the first one.

Thanks again,
Picola.

 

[AlphaFrog]

Hi AlphaFrog,

Thanks a lot for your help, works very well !

Let me ask you another one, what is the code to select all worksheets in a workbook, except sheets(1) ?

In fact I would like to add lines, columns, etc. to all worksheets except the first one.

Thanks again,
Picola.

You're welcome.

That's a whole new topic. It probably deserves it's own new thread.

This example will loop through each sheet except the first one.

    [color=darkblue]Dim[/color] i [color=darkblue]As[/color] [color=darkblue]Long[/color]
    [color=darkblue]For[/color] i = 2 [color=darkblue]To[/color] Sheets.Count       [color=green]'loop through each worksheet from sheet(2) to the last sheet[/color]
        Sheets(i).Rows(2).Insert    [color=green]'Insert a new row at row 2 on each sheet[/color]
    [color=darkblue]Next[/color] i

 

[SFPCFS]

I've read this whole thread and its alsmot got me to were I need, I wondered if you would be able to help me?

Based in the code you ahve written here, I'm trying to get it to do 3 auto filters, one after the other and then copy all the cells that meet the criteria for theem into worksheets in the book

My referance colum for the autofilter would be n(Starting on row5) with the data starting from row 6

There are three set criteria to filter (simple 2 letter text) and it just needs to copy from a-n all rows from 6 down(so under row 5 were I have my headings) to the respective sheets which have the 2 letters in there names

Is this a big change to the code here?

 

[AlphaFrog]

Hi SFPCFS. Try something like this. It filters your data on column N.

[color=darkblue]Sub[/color] Extract_Three_Filtered_Data_To_Worksheets()
    
    [color=green]'The 5th row of data is a header row.[/color]
    [color=green]'Three specific filtered values will be copied to it's own[/color]
    [color=green]'existing sheet's last used row[/color]
    
    [color=green]'Variables used by the macro[/color]
    [color=darkblue]Dim[/color] rngFilter [color=darkblue]As[/color] Range          [color=green]' Filter Range[/color]
    [color=darkblue]Dim[/color] vCriteria [color=darkblue]As[/color] [color=darkblue]Variant[/color]        [color=green]' One Filter criteria[/color]
    [color=darkblue]Dim[/color] arrCriteria [color=darkblue]As[/color] [color=darkblue]Variant[/color]      [color=green]' Array of all filter critera[/color]
    [color=darkblue]Const[/color] FilterCol [color=darkblue]As[/color] [color=darkblue]Long[/color] = 14    [color=green]' Column number to filter on (14 = column N)[/color]
        
    [color=green]' Three predefined criteria to filter on (simple 2 letter text)[/color]
    arrCriteria = Array("AA", "BB", "CC")
    
    [color=green]' Set the filter range (from A5 to the last used cell in column N)[/color]
    [color=green]'(Note: you can change this to meet your requirements)[/color]
    [color=darkblue]Set[/color] rngFilter = Range("A5", Range("N" & Rows.Count).End(xlUp))
    
    Application.ScreenUpdating = [color=darkblue]False[/color]
    
    [color=green]' Filter, Copy, and Paste each criteria to its own existing sheet[/color]
    [color=green]' with the same name as the criteria[/color]
    [color=darkblue]For[/color] [color=darkblue]Each[/color] vCriteria [color=darkblue]In[/color] arrCriteria
            
        [color=green]'Test if the data has at least one criteria value to filter[/color]
        [color=darkblue]If[/color] Application.CountIf(rngFilter.Columns(FilterCol), vCriteria) [color=darkblue]Then[/color]
                    
            [color=green]'This filters on the defined constant FilterCol (Column N)[/color]
            rngFilter.AutoFilter Field:=FilterCol, Criteria1:=vCriteria
            
            [color=green]' Copy and paste the filtered data to the next empty row of[/color]
            [color=green]' its existing worksheet with the same name as the criteria[/color]
            [color=darkblue]With[/color] rngFilter.Offset(1).Resize(rngFilter.Rows.Count - 1)
                .Copy
                [color=darkblue]With[/color] Sheets(vCriteria).Range("A" & Rows.Count).End(xlUp).Offset(1)
                    [color=green]'.PasteSpecial xlPasteColumnWidths           'Paste column widths[/color]
                    .PasteSpecial xlPasteValuesAndNumberFormats [color=green]'Paste values[/color]
                [color=darkblue]End[/color] [color=darkblue]With[/color]
            [color=darkblue]End[/color] [color=darkblue]With[/color]
            Application.CutCopyMode = [color=darkblue]True[/color]
        
        [color=darkblue]End[/color] [color=darkblue]If[/color]
        
    [color=darkblue]Next[/color] vCriteria
    
    rngFilter.Parent.AutoFilterMode = [color=darkblue]False[/color]
    Application.ScreenUpdating = [color=darkblue]True[/color]
    MsgBox "Data rows have been copied. ", , "Copy Complete"
    
[color=darkblue]End[/color] [color=darkblue]Sub[/color]

 

[SFPCFS]

Thats brilliant Sir!!!

Thank you so much for your time.

I do have another question but I'll message that if you don't mind - its semi linked to this, but its on a different macro that I have inherited as pre written

 

[AlphaFrog]

You're welcome.

Please don't message me questions. Start a new thread. That's the whole point of this open forum.