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]

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.

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]

 

[adamchase2]

Thank you so much. Everything worked perfectly.

 

[martines]

Hi, everybody!

This thread is real time saver.

So far the code limits the number of uniques. What I would like to know is how the filtered results can be limited by predefining the value in column A. The main goal is to copy only certain results, not all uniques.
To illustrate:
In the filtered column A I have values like: Active, Inactive; Closed, Paused etc. After filtering all values I would like to copy to the separate workbook, in the respective sheets, only the results which have values Active and Closed.

I would like to apologize for the newbie question, but I’m new to vba.


P.S.: Maybe this should be discussed separately, but is there also a way define which columns of the returned results are being copied to the separate workbook. Let’s say the results contain values from A:I, but I would like to copy only the results contained in columns B:D and F.

 

[AlphaFrog]

Hi and welcome to the forum martines. Kudos as well for searching for a solution first.

[COLOR=darkblue]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[/COLOR]

 

[Zdane]

Hi guys, I am absolutely newbie. I have data that's from column A to R and rows 200-250. I want to copy and paste whole rows (A to R) into different workbooks based on single columns criteria. The column I want to use is J which has dates( ex. 20130812, 20130813, 20130814). the dates could be anything but the format would be the same.


Sorry if its not clear, let me know and I can explain more....


Any help is appreciated, Thanks in advance,

 

[BertDeezy]

Alpha,

Thank you so much for the below. It has helped greatly! I am trying to add one more function to the code. I hope someone can help.
I would like to use the same code provided, but my source/master file has several worksheets. I am trying to filter for the same unique values on the additional worksheets and copy the rows to the corresponding worksheets on the destination file. Also, will need to include the number of rows in each sheet name. Your help is greatly appreciated! See my attempt below.

[/FONT][/COLOR]Sub Extract_Filter_Data_To_New_Workbook()    
    'This macro will copy all filtered rows from one worksheet, to another blank workbook
    'each unique filtered value will be copied to it's own workbook
    
    'Variables used by the macro
    Dim wbDest As Workbook
    Dim rngFilter As Range, rngUniques As Range
    Dim cell As Range
    Dim cell2 As Range
    Dim wsCount As Integer
    Dim I As Integer
    
    ' Set the filter range
    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
        On Error Resume Next
            ActiveSheet.ShowAllData
        On Error GoTo 0
        
    End With
    
    ' Filter, Copy, and Paste each unique to its own new workbook
    For Each cell In rngUniques


            ' Create a new workbook for each unique value
            Set wbDest = Workbooks.Add(xlWBATWorksheet)
            
            ' Set wsCount equal to the number of tabs in workbook
            wsCount = ThisWorkbook.Worksheets.Count - 2
            
            ' Begin loop through tabs
            For I = 1 To wsCount
            
                ' Filter on Column A (Field =1)
                rngFilter.AutoFilter Field:=1, Criteria1:=cell.Value
        
                ' Copy and paste the filtered data to its new workbook
                rngFilter.EntireRow.Copy
                With wbDest.ActiveSheet.Range("A1")
                .PasteSpecial xlPasteColumnWidths           'Paste column widths
                .PasteSpecial xlPasteValuesAndNumberFormats 'Paste values
                .PasteSpecial xlPasteFormats
                End With
                Application.CutCopyMode = True
        
                ' Name the destination sheet
                wbDest.ActiveSheet.Name = ThisWorkbook.ActiveSheet.Name & "_(" & wbDest.ActiveSheet.Rows.Count & ")"
                
                ' Add sheet to new workbook
                wbDest.Sheets.Add
                
                ' Select next sheet of master workbook
                ActiveSheet.Next.Select
        
            Next I
            
            'Save the destination workbook and close
            wbDest.SaveAs ThisWorkbook.Path & Application.PathSeparator & _
                cell.Value
            wbDest.Close False 'Close the new workbook
        
    Next cell


    rngFilter.Parent.AutoFilterMode = False
    Application.ScreenUpdating = True
    

End Sub[COLOR=#574123][FONT=system]

 

[AlphaFrog]

I would like to use the same code provided, but my source/master file has several worksheets. I am trying to filter for the same unique values on the additional worksheets and copy the rows to the corresponding worksheets on the destination file. Also, will need to include the number of rows in each sheet name.

Could you expand (greatly) on the description? I don't fully appreciate your source data configuration and the end result desired.

 

[BertDeezy]

The code works perfectly for one worksheet, but I would like to also copy the filtered values in the other worksheets of the workbook and copy them to new worksheets in the new workbook. Thanks again for your help.

 

[bradley729]

This is a great thread and has me in the right direction.
What I would like to do is call another macro to run on the new workbooks that are being created.
That macro includes the formatting of workbook as well as the saving of the workbook.
So basically, once the data is copied over to a new workbook i want to run the macro that have to do everything else.
Any help would be greatly appreciated.

 

[AlphaFrog]

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.