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

 

[AlphaFrog]

If counter > Range("G1").Value Then Exit For

 

[ricardomadaleno]

If counter > Range("G1").Value Then Exit For

It doesn't work
It works brilliantly if I put If counter > 5 Then Exit For, but when I try If counter > Range("G1").Value Then Exit For it only copies 1 unique value, no matter what the number in "G1" is...

could you help me?

thanks

 

[AlphaFrog]

[color=darkblue]Sub[/color] Extract_All_Data()

    [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 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, rngUniques [color=darkblue]As[/color] Range
    [color=darkblue]Dim[/color] cell [color=darkblue]As[/color] Range, counter [color=darkblue]As[/color] [color=darkblue]Integer[/color]
    [color=red]Dim lLimit As Long[/color]
    
    [color=green]'Limit the number of Uniques[/color]
    [COLOR="Red"]lLimit = ActiveSheet.Range("G1").Value[/COLOR]
    
    [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]' Create a new workbook with a sheet for each unique value[/color]
    Application.SheetsInNewWorkbook = rngUniques.Count
    [color=darkblue]Set[/color] wbDest = Workbooks.Add
    Application.SheetsInNewWorkbook = 3

    [color=green]' Filter, Copy, and Paste each unique to its' own sheet in the new workbook[/color]
    [color=darkblue]For[/color] [color=darkblue]Each[/color] cell [color=darkblue]In[/color] rngUniques
    
        counter = counter + 1
        [color=red]If counter > lLimit Then Exit For[/color]
        
        [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 it's unique sheet[/color]
        rngFilter.Resize(, 16).SpecialCells(xlCellTypeVisible).Copy Destination:=wbDest.Sheets(counter).Range("A1")
        [color=green]' Name the destination sheet[/color]
        wbDest.Sheets(counter).Name = cell.Value
        wbDest.Sheets(counter).Cells.Columns.AutoFit
        
    [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]

 

[ricardomadaleno]

simply perfect :D:D

Thank you so much!

 

[ricardomadaleno]

[color=darkblue]Sub[/color] Extract_All_Data()

    [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 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, rngUniques [color=darkblue]As[/color] Range
    [color=darkblue]Dim[/color] cell [color=darkblue]As[/color] Range, counter [color=darkblue]As[/color] [color=darkblue]Integer[/color]
    [color=red]Dim lLimit As Long[/color]
    
    [color=green]'Limit the number of Uniques[/color]
    [COLOR="Red"]lLimit = ActiveSheet.Range("G1").Value[/COLOR]
    
    [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]' Create a new workbook with a sheet for each unique value[/color]
    Application.SheetsInNewWorkbook = rngUniques.Count
    [color=darkblue]Set[/color] wbDest = Workbooks.Add
    Application.SheetsInNewWorkbook = 3

    [color=green]' Filter, Copy, and Paste each unique to its' own sheet in the new workbook[/color]
    [color=darkblue]For[/color] [color=darkblue]Each[/color] cell [color=darkblue]In[/color] rngUniques
    
        counter = counter + 1
        [color=red]If counter > lLimit Then Exit For[/color]
        
        [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 it's unique sheet[/color]
        rngFilter.Resize(, 16).SpecialCells(xlCellTypeVisible).Copy Destination:=wbDest.Sheets(counter).Range("A1")
        [color=green]' Name the destination sheet[/color]
        wbDest.Sheets(counter).Name = cell.Value
        wbDest.Sheets(counter).Cells.Columns.AutoFit
        
    [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]

I'm sorry, I know I said it was perfect, but I need one more thing :$

What do I need to do, if my column to filter the unique values is not the "A" column?

I already changed the code to filter to the "C" column, but now, when it copies the values, it only copies from the "C" onward...

I need it to filter on "C", but still copy from the "A" onward...

can you help me?

 

[jonfull]

THANKS - this is awesome and exactly what I was needing today.

 

[Superdot]

Yes, awesome! Thank you! I have one small question - how can I preserve the column widths when pasting to the new worksheet?
Again, thanks for the excellent help.

 

[AlphaFrog]

Yes, awesome! Thank you! I have one small question - how can I preserve the column widths when pasting to the new worksheet?
Again, thanks for the excellent help.

[COLOR=darkblue]Sub[/COLOR] Extract_All_Data()
    
    [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 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, rngUniques [COLOR=darkblue]As[/COLOR] Range
    [COLOR=darkblue]Dim[/COLOR] cell [COLOR=darkblue]As[/COLOR] Range, 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]'(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]' Create a new workbook with a sheet for each unique value[/COLOR]
    Application.SheetsInNewWorkbook = rngUniques.Count
    [COLOR=darkblue]Set[/COLOR] wbDest = Workbooks.Add
    Application.SheetsInNewWorkbook = 3
    
    [COLOR=green]' Filter, Copy, and Paste each unique to its' own sheet in the new workbook[/COLOR]
    [COLOR=darkblue]For[/COLOR] [COLOR=darkblue]Each[/COLOR] cell [COLOR=darkblue]In[/COLOR] rngUniques
    
        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:=cell.Value
        
        [COLOR=green]' Copy and paste the filtered data to it's unique sheet[/COLOR]
        rngFilter.Resize(, 16).SpecialCells(xlCellTypeVisible).Copy Destination:=wbDest.Sheets(counter).Range("A1")
        [COLOR=green]' Name the destination sheet[/COLOR]
        wbDest.Sheets(counter).Name = cell.Value
[COLOR=#ff0000]        rngFilter.Parent.Rows(1).Copy
        wbDest.Sheets(counter).Rows(1).PasteSpecial xlPasteColumnWidths
        Application.CutCopyMode = True[/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]

 

[Superdot]

Perfect! I cannot thank you enough. This is an incredible resource - thank you for sharing your knowledge so freely.

cheers!

 

[adamchase2]

This works perfectly as described. Is there to change the code to save to a new file for each unique value instead of a tab? Also upon save add the current date to the name of the file?

Thanks again for this amazing code.