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]

Sub Extract_All_Data()

    'this macro assumes that your first row of data is a header row.
    'will copy all filtered rows from one worksheet, to another blank workbook
    'each unique filtered value will be copied to it's own sheet
    
    'Variables used by the macro
    Dim wbDest As Workbook
    Dim rngFilter As Range, rngUniques As Range
    Dim cell As Range, counter As Integer
    
    ' Set the filter range (from A1 to the last used cell in column A, all used columns
    '(Note: you can change this to meet your requirements)
    Set rngFilter = Range("A1", Range("A" & Rows.Count).End(xlUp)).Resize(, _
                    Cells.Find("*", [A1], Searchorder:=xlByColumns, Searchdirection:=xlPrevious).Column)
    
    Application.ScreenUpdating = False
    
    With rngFilter
        
        ' Filter column A to show only one of each item (uniques) in column A
        .AdvancedFilter Action:=xlFilterInPlace, Unique:=True
        
        ' Set a variable to the Unique values
        Set rngUniques = Range("A2", Range("A" & Rows.Count).End(xlUp)).SpecialCells(xlCellTypeVisible)
        
        ' Clear the filter
        ActiveSheet.ShowAllData
        
    End With
    
    ' Create a new workbook with a sheet for each unique value
    Application.SheetsInNewWorkbook = rngUniques.Count
    Set wbDest = Workbooks.Add
    Application.SheetsInNewWorkbook = 3

    ' Filter, Copy, and Paste each unique to its' own sheet in the new workbook
    For Each cell In rngUniques
    
        counter = counter + 1
        
        'NOTE - this filter is on column A (field:=1), to change
        'to a different column you need to change the field number
        rngFilter.AutoFilter field:=1, Criteria1:=cell.Value
        
        ' Copy and paste the filtered data to it's unique sheet
        rngFilter.SpecialCells(xlCellTypeVisible).Copy Destination:=wbDest.Sheets(counter).Range("A1")
        ' Name the destination sheet
        wbDest.Sheets(counter).Name = cell.Value
        
    Next cell
    
    rngFilter.Parent.AutoFilterMode = False
    Application.ScreenUpdating = True
    
End Sub

 

[lakersbg]

Dear Alphafrog, thanks a lot! I really appreciate what you've done for me! However, I get two errors, the first one was about the filter but I overcame it using this script:
on error resume next
activesheet.showalldata
on error goto 0

The second error which I have not yet solved is "can't create another sheet with the same name". Didn't you get the same error when you ran the macro?
Thank you in advance for the help!
Best Regards,
Lakersbg

 

[AlphaFrog]

I don't have your data so I can't duplicate the sheet names. There is something in your data values where two sheet names will be the same for some reason.

Change this line ...

wbDest.Sheets(counter).Name = cell.Value

To this...

wbDest.Sheets(counter).Name = Counter & " " & cell.Value

That will insure no two sheets have the same name. Or you could just comment out that line to not rename the sheets.

 

[lakersbg]

Thanks for the help! However, there are more glitches to be sorted out. When I run the macro, it creates not a single sheet for each account, but multiple sheets according to the number of occurrences, so if an account is present 10 times, it creates 10 sheets with this account. When I ran the macro using my data I got the following error: run-time error 1004. Number must be between 1 & 255. The script line causing the error is:
Application.SheetsInNewWorkbook = rngUniques.Count
Here is a link if you want to download a sample of my data:
http://tranz.it/load.php?id=t9I5kkMp8uwDfT2X671795
The site is in Bulgarian, but just fill in the security pass and click on the download link.

I will greatly appreciate it if you can help me on this final "obstacle"
Best Regards,
Lakersbg

 

[AlphaFrog]

Sub Extract_All_Data()

    'this macro assumes that your first row of data is a header row.
    'will copy all filtered rows from one worksheet, to another blank workbook
    'each unique filtered value will be copied to it's own sheet
    
    'Variables used by the macro
    Dim wbDest As Workbook
    Dim rngFilter As Range, rngUniques As Range
    Dim cell As Range, counter As Integer
    
    ' Set the filter range (from A1 to the last used cell in column A)
    '(Note: you can change this to meet your requirements)
    Set rngFilter = Range("A1", Range("A" & Rows.Count).End(xlUp))
    
    Application.ScreenUpdating = False
    
    With rngFilter
        
        ' Filter column A to show only one of each item (uniques) in column A
        .AdvancedFilter Action:=xlFilterInPlace, Unique:=True
        
        ' Set a variable to the Unique values
        Set rngUniques = Range("A2", Range("A" & Rows.Count).End(xlUp)).SpecialCells(xlCellTypeVisible)
        
        ' Clear the filter
        ActiveSheet.ShowAllData
        
    End With
    
    ' Create a new workbook with a sheet for each unique value
    Application.SheetsInNewWorkbook = rngUniques.Count
    Set wbDest = Workbooks.Add
    Application.SheetsInNewWorkbook = 3

    ' Filter, Copy, and Paste each unique to its' own sheet in the new workbook
    For Each cell In rngUniques
    
        counter = counter + 1
        
        'NOTE - this filter is on column A (field:=1), to change
        'to a different column you need to change the field number
        rngFilter.AutoFilter field:=1, Criteria1:=cell.Value
        
        ' Copy and paste the filtered data to it's unique sheet
        rngFilter.Resize(, 16).SpecialCells(xlCellTypeVisible).Copy Destination:=wbDest.Sheets(counter).Range("A1")
        ' Name the destination sheet
        wbDest.Sheets(counter).Name = cell.Value
        wbDest.Sheets(counter).Cells.Columns.AutoFit
        
    Next cell
    
    rngFilter.Parent.AutoFilterMode = False
    Application.ScreenUpdating = True
    
End Sub

 

[lakersbg]

Thank you very much If you ever pass by Bulgaria, tell me so that I could buy you a beer ray:

 

[ricardomadaleno]

Sub Extract_All_Data()

    'this macro assumes that your first row of data is a header row.
    'will copy all filtered rows from one worksheet, to another blank workbook
    'each unique filtered value will be copied to it's own sheet
    
    'Variables used by the macro
    Dim wbDest As Workbook
    Dim rngFilter As Range, rngUniques As Range
    Dim cell As Range, counter As Integer
    
    ' Set the filter range (from A1 to the last used cell in column A)
    '(Note: you can change this to meet your requirements)
    Set rngFilter = Range("A1", Range("A" & Rows.Count).End(xlUp))
    
    Application.ScreenUpdating = False
    
    With rngFilter
        
        ' Filter column A to show only one of each item (uniques) in column A
        .AdvancedFilter Action:=xlFilterInPlace, Unique:=True
        
        ' Set a variable to the Unique values
        Set rngUniques = Range("A2", Range("A" & Rows.Count).End(xlUp)).SpecialCells(xlCellTypeVisible)
        
        ' Clear the filter
        ActiveSheet.ShowAllData
        
    End With
    
    ' Create a new workbook with a sheet for each unique value
    Application.SheetsInNewWorkbook = rngUniques.Count
    Set wbDest = Workbooks.Add
    Application.SheetsInNewWorkbook = 3

    ' Filter, Copy, and Paste each unique to its' own sheet in the new workbook
    For Each cell In rngUniques
    
        counter = counter + 1
        
        'NOTE - this filter is on column A (field:=1), to change
        'to a different column you need to change the field number
        rngFilter.AutoFilter field:=1, Criteria1:=cell.Value
        
        ' Copy and paste the filtered data to it's unique sheet
        rngFilter.Resize(, 16).SpecialCells(xlCellTypeVisible).Copy Destination:=wbDest.Sheets(counter).Range("A1")
        ' Name the destination sheet
        wbDest.Sheets(counter).Name = cell.Value
        wbDest.Sheets(counter).Cells.Columns.AutoFit
        
    Next cell
    
    rngFilter.Parent.AutoFilterMode = False
    Application.ScreenUpdating = True
    
End Sub

Hi,

I have to thank you for this... it is simply brilliant.

I was wondering, would it be possible to have it copy only a certain amount of the unique values?
I mean, at the moment this code creates a new workbook with a sheet for every unique value on column A; but would it be possible to do it just for the first (lets say) 5 unique values?

thanks a lot

 

[AlphaFrog]

...would it be possible to do it just for the first (lets say) 5 unique values?

Add the line in red after the counter line.

    ' Filter, Copy, and Paste each unique to its' own sheet in the new workbook
    For Each cell In rngUniques
    
        counter = counter + 1
        [COLOR="Red"]If counter > 5 Then Exit For[/COLOR]

 

[ricardomadaleno]

Add the line in red after the counter line.

    ' Filter, Copy, and Paste each unique to its' own sheet in the new workbook
    For Each cell In rngUniques
    
        counter = counter + 1
        [COLOR="Red"]If counter > 5 Then Exit For[/COLOR]

AWESOME :D

thank you so much for this just one more thing for it to be perfect; would it be possible to have the "number 5" defined in a cell?
for instance If counter > ("G1") Then Exit For
(Forgive my very poor knowledge on vba code)