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

 

[bradley729]

Hi bradley729 and welcome to the forum. Well done on searching for a solution first.

I've posted half a dozen versions of the code and I don't know which one you like.

Calling another macro is relatively easy e.g.
Call MyMacro

It's more a matter of when\where in the code you call your macro. Generally right after the data is copied could work. That's the best I can do given the limited specifics provided.

Thanks, exactly what I needed.
I was having problems on the placement of the Call function.
This has saved me days of work.

 

[AlphaFrog]

Thanks, exactly what I needed.
I was having problems on the placement of the Call function.
This has saved me days of work.

You're welcome. That was easy though I'm not really sure what I did to help. Anyway, as long as it works.

 

[juhanar]

Hi, guys!

Amazing thread!
I went for the version of the code which filters and copies each of the predefined values to its own worksheet. So far, so good.
But I wanted to format and enhance the worksheets in the newly created workbook a little bit more by applying Auto filter in each sheet.

To do that I defined a new variable:

Dim ws As Worksheet

And then I’ve added the following code just before naming the destination sheets:

For Each ws In wbDest.Worksheets
ws.Range("A1").AutoFilter
Next ws

Unfortunately the code above applied filter only to the first of the two destination sheets. In order to test what happens I’ve changed the code a little bit:

For Each ws In wbExport.Worksheets
ws.Select
Range("A1").Select
Selection.AutoFilter
Next ws

But yet again filter is applied only to the first sheet. On the second one - cell A1 is being selected, but no auto filter is applied.

I would really appreciate your help!
Thank you in advance.

 

[AlphaFrog]

Hi, guys!
I went for the version of the code which filters and copies each of the predefined values to its own worksheet.

This thread has been going on for three years now.
What version are you using (what is the Thread #) or can you post your whole code?

 

[juhanar]

This thread has been going on for three years now.
What version are you using (what is the Thread #) or can you post your whole code?

Would be better to post my code. Since all of my source data is in a table I've made few changes here and there:

Sub Extract_Predefined_Criteria_Data()    
    'this macro assumes that your first row of data is a header row.
    'will copy filtered rows from one worksheet, to a new workbook
    'each filter criteria ("Active", "Closed") will be copied to it's own sheet
    
    'Variables used by the macro
    Dim wbDest As Workbook
    Dim rngFilter As Range
    Dim arrFilterCritera As Variant
    Dim vCriteria As Variant
    Dim counter As Integer
    Dim lst As ListObject
    Dim ws As Worksheet
    
    'The range of cells is in a table
    Sheets("Sheet1").Select
    Set lst = ActiveSheet.ListObjects("Table1")
    If lst.AutoFilter.FilterMode Then
    lst.AutoFilter.ShowAllData
    End If
          
    ' Set the filter range
     Set rngFilter = Range("E1", Range("E" & Rows.Count).End(xlUp))
    
    ' Prevent screen from flickering
    Application.ScreenUpdating = False
    
    ' Predefined filter criteria for column E
    ' Change to suit
    arrFilterCritera = Array("Completed", "Postponed")
    
    ' Create a new workbook with a sheet for each criteria
    Application.SheetsInNewWorkbook = UBound(arrFilterCritera) - LBound(arrFilterCritera) + 1
    Set wbDest = Workbooks.Add
    Application.SheetsInNewWorkbook = 3
    
    ' Filter, Copy, and Paste each criteria to its own sheet in the new workbook
    For Each vCriteria In arrFilterCritera
    
        counter = counter + 1
        
        'NOTE - this filter is on column E (Field:=5), to change
        'to a different column you need to change the field number
        rngFilter.AutoFilter Field:=5, Criteria1:=vCriteria
        
        ' Copy and paste the filtered data to its unique sheet
        ' Copy filtered rows from columns A, D, and F
        Intersect(rngFilter.EntireRow, rngFilter.Parent.Range("A:A,D:D,F:F")).Copy
        wbDest.Sheets(counter).Range("E1").Offset(0, -4).PasteSpecial xlPasteColumnWidths
        wbDest.Sheets(counter).Range("E1").Offset(0, -4).PasteSpecial xlPasteFormats
        wbDest.Sheets(counter).Range("E1").Offset(0, -4).PasteSpecial xlPasteValuesAndNumberFormats
        Application.CutCopyMode = True
                             
        ' Apply filters on destination sheets
[COLOR=#ff0000]        For Each ws In wbDest.Worksheets
        ws.Select
        Range("A1").Select
        Selection.AutoFilter
        Next ws[/COLOR]
        
        ' Name the destination sheet
        wbDest.Sheets(counter).Name = vCriteria
        
        'Save the new workbook
        Application.DisplayAlerts = False
        wbDest.SaveAs Filename:="C:\Exported\Test", FileFormat:=xlOpenXMLWorkbook, AccessMode:=xlShared
        Application.DisplayAlerts = True
                
    Next vCriteria
    
    'Clean-up: Undo filters, close new workbook, restore screen updating
    lst.ShowAutoFilter = False
    wbDest.Close
    Application.ScreenUpdating = True
    
End Sub

 

[AlphaFrog]

Forgot to welcome you juhanar and good job on doing a search first. It's a little surprising how many new comers find this thread.

Try this for the 'Apply filters on destination sheets

        [COLOR=green]' Apply filters on destination sheets[/COLOR]
        wbDest.Sheets(counter).UsedRange.Resize(, 1).AutoFilter [COLOR=green]'Autofilter only the first column[/COLOR]
        [COLOR=green]'alternativly[/COLOR]
        [COLOR=green]'''wbDest.Sheets(counter).UsedRange.AutoFilter 'Autofilter all columns[/COLOR]

I haven't tested this but I think that's your problem. It filters just the one current destination sheet after its data is pasted instead of looping all the sheets.

Also, move your code block 'Save the new workbook after the Next vCriteria command. That would save the destination workbook only once after all the data is copied. Currently it's saving once for each worksheet. This wasn't your problem, but it's a little more efficient.

 

[juhanar]

Forgot to welcome you juhanar and good job on doing a search first. It's a little surprising how many new comers find this thread.

Try this for the 'Apply filters on destination sheets

        [COLOR=green]' Apply filters on destination sheets[/COLOR]
        wbDest.Sheets(counter).UsedRange.Resize(, 1).AutoFilter [COLOR=green]'Autofilter only the first column[/COLOR]
        [COLOR=green]'alternativly[/COLOR]
        [COLOR=green]'''wbDest.Sheets(counter).UsedRange.AutoFilter 'Autofilter all columns[/COLOR]

I haven't tested this but I think that's your problem. It filters just the one current destination sheet after its data is pasted instead of looping all the sheets.

Also, move your code block 'Save the new workbook after the Next vCriteria command. That would save the destination workbook only once after all the data is copied. Currently it's saving once for each worksheet. This wasn't your problem, but it's a little more efficient.

Thank you a lot for the code and the optimization suggestion as well!
Worked like a charm.

As for the fact that many newcomers find this thread, maybe it's because the functionality that is being discussed is really helpful and common in day to day use. Taking into account how many variations of the code have been posted already, it's no surprise that this thread is so popular. And it's mainly thanks to you!




Great work!

 

[Alfaia]

Hi AlphaFrog,

Many thanks for this brilliant and useful post I'm trying to work off your code posted here as I want to filter data from a sheet of a workbook into a new workbook and have each filtered item separated into different worksheets, I also want to keep the same header in each worksheet. So I think all your code needs is a few minor changes but I have been at this for quite a while and still I'm getting nowhere, It's quite likely because I am extremely new to vba and completely self taught so far.

Can you help?

Many thanks

 

[Alfaia]

Just to add the mentioned code

Sub[/COLOR] Extract_Predefined_Criteria_Data()          [COLOR=green]'this macro assumes that your first row of data is a header row.[/COLOR]     [COLOR=green]'will copy filtered rows from one worksheet, to a new workbook[/COLOR]     [COLOR=green]'each filter criteria ("Active", "Closed") will be copied to it's own sheet[/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     [COLOR=darkblue]Dim[/COLOR] arrFilterCritera [COLOR=darkblue]As[/COLOR] [COLOR=darkblue]Variant[/COLOR]     [COLOR=darkblue]Dim[/COLOR] vCriteria [COLOR=darkblue]As[/COLOR] [COLOR=darkblue]Variant[/COLOR]     [COLOR=darkblue]Dim[/COLOR] counter [COLOR=darkblue]As[/COLOR] [COLOR=darkblue]Integer[/COLOR]          [COLOR=green]' Set the filter range (from A1 to the last used cell in column A)[/COLOR]     [COLOR=green]' Change to suit[/COLOR]     [COLOR=darkblue]Set[/COLOR] rngFilter = Range("A1", Range("A" & Rows.Count).End(xlUp))          [COLOR=green]' Prevent screen from flickering[/COLOR]     Application.ScreenUpdating = [COLOR=darkblue]False[/COLOR]          [COLOR=green]' Predefined filter criteria for column A[/COLOR]     [COLOR=green]' Change to suit[/COLOR]     arrFilterCritera = Array("Active", "Closed")          [COLOR=green]' Create a new workbook with a sheet for each criteria[/COLOR]     Application.SheetsInNewWorkbook = [COLOR=darkblue]UBound[/COLOR](arrFilterCritera) - [COLOR=darkblue]LBound[/COLOR](arrFilterCritera) + 1     [COLOR=darkblue]Set[/COLOR] wbDest = Workbooks.Add     Application.SheetsInNewWorkbook = 3          [COLOR=green]' Filter, Copy, and Paste each criteria to its own sheet in the new workbook[/COLOR]     [COLOR=darkblue]For[/COLOR] [COLOR=darkblue]Each[/COLOR] vCriteria [COLOR=darkblue]In[/COLOR] arrFilterCritera              counter = counter + 1                  [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:=vCriteria                  [COLOR=green]' Copy and paste the filtered data to its unique sheet[/COLOR]         [COLOR=green]' Copy filtered rows from columns B, D, and F[/COLOR]         Intersect(rngFilter.EntireRow, rngFilter.Parent.Range("B:B,D:D,F:F")).Copy         wbDest.Sheets(counter).Range("A1").PasteSpecial xlPasteColumnWidths         wbDest.Sheets(counter).Range("A1").PasteSpecial xlPasteFormats         wbDest.Sheets(counter).Range("A1").PasteSpecial xlPasteValuesAndNumberFormats         Application.CutCopyMode = [COLOR=darkblue]True[/COLOR]                  [COLOR=green]' Name the destination sheet[/COLOR]         wbDest.Sheets(counter).Name = vCriteria              [COLOR=darkblue]Next[/COLOR] vCriteria          [COLOR=green]'Clean-up: Undo filters, restore screen updating[/COLOR]     rngFilter.Parent.AutoFilterMode = [COLOR=darkblue]False[/COLOR]     Application.ScreenUpdating = [COLOR=darkblue]True[/COLOR]      [COLOR=darkblue]End[/COLOR] [COLOR=darkblue]Sub

</pre>

 

[AlphaFrog]

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.