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

lakersbg · Nov 11, 2010

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

VBABEGINER · Apr 28, 2016

Dear sir,

can you please tell me how do I use this code-

'Save the destination workbook and close
strPath = "C:\Main Folder\" & cell.Value & "\"
If Dir(strPath, vbDirectory) = "" Then MkDir strPath
wbDest.SaveAs strPath & cell.Value & " " & Format(Date, "mmm_dd_yyyy")
ActiveWorkbook.Close

with this one-

' Save\close the new workbook
ActiveWorkbook.SaveAs Filename:=ThisWorkbook.Path & "\" & cell.Value, FileFormat:=51
ActiveWorkbook.Close

I want to save all the workbooks in C\Main Folder\ .....saving by this name...cell.Value

cindrella39 · May 5, 2016

Hi Everyone ,

I am new to this group and new to VBA too . I really appreciate all efforts by everyone to answer the questions posted here.

I am able to filter copy and paste the data but that is not efficient as I used recording and then tweaked it to my needs.

Coming to my requirement .

I am extracting data from the database server in to the data sheet .After pulling data I need to put that data in to the multiple worksheets in the same workbook .
All worksheets are also predefined and created . As I am connecting to database every time I refresh the number of records changes .

Lets say Sheet1 -Data sheet , Sheet2 - X , Sheet3 - Y

Data sheet has employee data ,

Sheet 2 Criteria ..

If support_org = 'A_X' and status = 'active' or 'inactive' then pull data from data sheet and place it in sheet2 ie X

Sheet 3 Criteria

If support_org = 'B_Y' and status = 'active' or 'inactive' then pull data from data sheet and place it in sheet3 ie Y

'Selecting the X sheet
Sheets("X").Select
Range("A2").Select
PasteCount = Range("A2").CurrentRegion.Rows.Count
PasteCount = "A2:O" & PasteCount
Range(PasteCount).Select
'clearing the contents of the sheet
Selection.ClearContents
'Selecting the data from data sheet
Sheets(" Data").Select
ActiveSheet.ListObjects("Table_Data").Range. _
AutoFilter Field:=4, Criteria1:="A_X"
ActiveSheet.ListObjects("Data").Range. _
AutoFilter Field:=2, Criteria1:="=Active", Operator:=xlOr, Criteria2 _
:="=Inactive"
Rows("2:1048576").Select
Selection.Copy
Sheets("X").Select
Range("A2").Select
ActiveSheet.Paste
Range("A1").Select

'Selecting the Y sheet
Sheets("Y").Select
Range("A2").Select
PasteCount = Range("A2").CurrentRegion.Rows.Count
PasteCount = "A2:O" & PasteCount
Range(PasteCount).Select
'clearing the contents of the sheet
Selection.ClearContents
'Selecting the data from data sheet
Sheets(" Data").Select
ActiveSheet.ListObjects("Table_Data").Range. _
AutoFilter Field:=4, Criteria1:="B_Y"
ActiveSheet.ListObjects("Data").Range. _
AutoFilter Field:=2, Criteria1:="=Active", Operator:=xlOr, Criteria2 _
:="=Inactive"
Rows("2:1048576").Select
Selection.Copy
Sheets("Y").Select
Range("A2").Select
ActiveSheet.Paste
Range("A1").Select

Similar to above X and Y sheets there two more sheets and data is getting pasted properly but after filtering I am selecting the entire rows , it is not efficient I feel .

I tried using rows up and down and left and right logics too but it didn't work for me ..

any help would be greatly appreciated ..

Thanks a lot

cindrella39 · May 5, 2016

It need not be table as below
ActiveSheet.ListObjects("Table_Data").Range. _
AutoFilter Field:=4, Criteria1:="A_X"

it can be ActiveSheet.Range("$A:$O").AutoFilter Field:=4, Criteria1:= _
"A_X"

Also some times for support org in criteria and Status =Active or Inactive there may be no records but It should not throw error as it is valid case it needs to go to next case ...

cindrella39 said:
Hi Everyone ,

I am new to this group and new to VBA too . I really appreciate all efforts by everyone to answer the questions posted here.

I am able to filter copy and paste the data but that is not efficient as I used recording and then tweaked it to my needs.

Coming to my requirement .

I am extracting data from the database server in to the data sheet .After pulling data I need to put that data in to the multiple worksheets in the same workbook .
All worksheets are also predefined and created . As I am connecting to database every time I refresh the number of records changes .

Lets say Sheet1 -Data sheet , Sheet2 - X , Sheet3 - Y

Data sheet has employee data ,

Sheet 2 Criteria ..

If support_org = 'A_X' and status = 'active' or 'inactive' then pull data from data sheet and place it in sheet2 ie X

Sheet 3 Criteria

If support_org = 'B_Y' and status = 'active' or 'inactive' then pull data from data sheet and place it in sheet3 ie Y

'Selecting the X sheet
Sheets("X").Select
Range("A2").Select
PasteCount = Range("A2").CurrentRegion.Rows.Count
PasteCount = "A2:O" & PasteCount
Range(PasteCount).Select
'clearing the contents of the sheet
Selection.ClearContents
'Selecting the data from data sheet
Sheets(" Data").Select
ActiveSheet.ListObjects("Table_Data").Range. _
AutoFilter Field:=4, Criteria1:="A_X"
ActiveSheet.ListObjects("Data").Range. _
AutoFilter Field:=2, Criteria1:="=Active", Operator:=xlOr, Criteria2 _
:="=Inactive"
Rows("2:1048576").Select
Selection.Copy
Sheets("X").Select
Range("A2").Select
ActiveSheet.Paste
Range("A1").Select

'Selecting the Y sheet
Sheets("Y").Select
Range("A2").Select
PasteCount = Range("A2").CurrentRegion.Rows.Count
PasteCount = "A2:O" & PasteCount
Range(PasteCount).Select
'clearing the contents of the sheet
Selection.ClearContents
'Selecting the data from data sheet
Sheets(" Data").Select
ActiveSheet.ListObjects("Table_Data").Range. _
AutoFilter Field:=4, Criteria1:="B_Y"
ActiveSheet.ListObjects("Data").Range. _
AutoFilter Field:=2, Criteria1:="=Active", Operator:=xlOr, Criteria2 _
:="=Inactive"
Rows("2:1048576").Select
Selection.Copy
Sheets("Y").Select
Range("A2").Select
ActiveSheet.Paste
Range("A1").Select

Similar to above X and Y sheets there two more sheets and data is getting pasted properly but after filtering I am selecting the entire rows , it is not efficient I feel .

I tried using rows up and down and left and right logics too but it didn't work for me ..

any help would be greatly appreciated ..

Thanks a lot

thedogg · May 24, 2016

I am using the code from first page (each range in new worksheet in the same workbook) and when I am using to much data I have error with Application.SheetsInNewWorkbook = rngUniques.Count. Is there any limit for rngUniques.Count?

I am able to generate around 250 worksheets in one workbook but when I try with 400 it stops exactly on Application.SheetsInNewWorkbook = rngUniques.Count. Is it possible to improve it somehow?

Code:

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

AlphaFrog · May 24, 2016

thedogg said:
I am using the code from first page (each range in new worksheet in the same workbook) and when I am using to much data I have error with Application.SheetsInNewWorkbook = rngUniques.Count. Is there any limit for rngUniques.Count?

I am able to generate around 250 worksheets in one workbook but when I try with 400 it stops exactly on Application.SheetsInNewWorkbook = rngUniques.Count. Is it possible to improve it somehow?

Apparently there is a limit of 255 sheets that can be in a new blank workbook. But then you can add more sheets to it after its creation. Seems silly. The code below will add more sheets if needed.

Replace this code...

Code:

    [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

With this...

Code:

    [color=green]' Create a new workbook with a sheet for each unique value[/color]
    Application.SheetsInNewWorkbook = Application.Min(rngUniques.Count, 255)
    [color=darkblue]Set[/color] wbDest = Workbooks.Add
    Application.SheetsInNewWorkbook = 3
    [color=darkblue]If[/color] rngUniques.Count > 255 [color=darkblue]Then[/color]
        [color=darkblue]Do[/color] [color=darkblue]Until[/color] wbDest.Sheets.Count = rngUniques.Count
            wbDest.Sheets.Add After:=wbDest.Sheets(wbDest.Sheets.Count)
        [color=darkblue]Loop[/color]
    [color=darkblue]End[/color] [color=darkblue]If[/color]

thedogg · May 25, 2016

Thanks AlphaFrog it is working great!!!!!! Have a wonderful day!

beauty · May 25, 2016

VBA: autofilter criteria

Hello. I tried to write VBA code for autofilter cell ending with a specific alphabet. I used For Loop but anyhow the result is wrong and never ending loop. Please help. TQVM.

This is my code.

Sub criteria()
'
' criteria Macro
'

Dim i As Long
last_row = Range("A" & Rows.Count).End(xlUp).Row

For i = 2 To last_row
If Range("A1").AutoFilter(7, Criteria1:="=*A", Operator:=xlAnd) Then
Range("AS" & i).Value = "North"

ElseIf Range("A1").AutoFilter(7, Criteria1:="=*B", Operator:=xlAnd) Then
Range("AS" & i).Value = "South"

ElseIf Range("A1").AutoFilter(7, Criteria1:="=*C", Operator:=xlAnd) Then
Range("AS" & i).Value = "East"

Else
Range("AS" & i).Value = "West"
End If

Next i

End Sub

Icesurf3r · May 25, 2016

Re: VBA: autofilter criteria

Hi There,

Yet another newbie, who is finding this thread extremely useful. However, none of the code does exactly what I need, so I have been trawling backwards and forwards through all the code to try an cannibalise it to fit my needs, unfortunately I have not been able to get it to work.

The workbook I am creating will not be shared, but it will be used by several people - so there is a chance that columns may be filtered. My spread sheet has a header row, with the data starting in row 2 (with the sheet titled Initiative Tracker) and when the user clicks a button I need it to search column D for every occurrence of the word Yes - then copy all the data associated with that row into a new workbook with an identical header row (So the data in the new workbook is identical to the original)- making sure that if any column is filtered- it un-filters the respective columns so it can search all the data.

The workbook doesn't need to have a specific name, as the users who extract this information will save it with their preferred name.

The code I have tried, but which doesn't work is:

Code:

Dim thisWB  As String

Dim newWB As String

    thisWB = ActiveWorkbook.Name
    
    On Error Resume Next
    Sheets("tempsheet").Delete
    On Error GoTo 0
    
    Sheets.Add
    ActiveSheet.Name = "tempsheet"
    
    Sheets("Sheet1").Select
    
    If ActiveSheet.AutoFilterMode Then
        Cells.Select
        
        On Error Resume Next
        
        ActiveSheet.ShowAllData
        
        On Error GoTo 0
    
    End If
    
    Columns("B:B").Select
    Selection.Copy
    
    Sheets("tempsheet").Select
    Range("A1").Select
    ActiveSheet.Paste
    Application.CutCopyMode = False
    
    If (Cells(1, 1) = "") Then
        lastrow = Cells(1, 1).End(xlDown).Row
        
        If lastrow <> Rows.Count Then
            Range("A1:A" & lastrow - 1).Select
            Selection.Delete Shift:=xlUp
        End If
    
    End If
    
    Columns("A:A").Select
    Columns("A:A").AdvancedFilter Action:=xlFilterCopy, _
                CopyToRange:=Range("B1"), Unique:=True
    
    Columns("A:A").Delete
    
    Cells.Select
    Selection.Sort _
            Key1:=Range("A2"), Order1:=xlAscending, _
            Header:=xlYes, OrderCustom:=1, _
            MatchCase:=False, Orientation:=xlTopToBottom, _
            DataOption1:=xlSortNormal
    
    lMaxSupp = Cells(Rows.Count, 1).End(xlUp).Row
    
    For suppno = 2 To lMaxSupp
    
        Windows(thisWB).Activate

        supName = Sheets("tempsheet").Range("A" & suppno)
        
        If supName <> "" Then

            Workbooks.Add
            ActiveWorkbook.SaveAs supName
            newWB = ActiveWorkbook.Name
            
            Windows(thisWB).Activate

            Sheets("Sheet1").Select
            Cells.Select
            
            If ActiveSheet.AutoFilterMode = False Then
                Selection.AutoFilter
            End If
            
            Selection.AutoFilter Field:=2, Criteria1:="=" & supName, _
                        Operator:=xlAnd, Criteria2:="<>"
            
            lastrow = Cells(Rows.Count, 2).End(xlUp).Row

            Rows("1:" & lastrow).Copy
            
            Windows(newWB).Activate
            ActiveSheet.Paste

            ActiveWorkbook.Save
            ActiveWorkbook.Close
            
        End If
    
    Next
    
    Sheets("tempsheet").Delete
    
    Sheets("Sheet1").Select
    If ActiveSheet.AutoFilterMode Then
        Cells.Select
        ActiveSheet.ShowAllData
    End If

End Sub

Apologies if this doesn't make sense, I have tried to explain it as best I can - So I would appreciate any help I can get. Thanks in Advance

AlphaFrog · May 25, 2016

Re: VBA: autofilter criteria

It made sense except the code posted isn't close to the description.

Code:

[color=darkblue]Sub[/color] Yes()
    
    [color=darkblue]If[/color] ActiveSheet.FilterMode [color=darkblue]Then[/color] ActiveSheet.ShowAllData
    
    [color=darkblue]With[/color] ActiveSheet.Range("A1").CurrentRegion
        .AutoFilter Field:=4, Criteria1:="Yes"
        Workbooks.Add xlWBATWorksheet
        .Copy
        Range("A1").PasteSpecial xlPasteAll
        Range("A1").PasteSpecial xlPasteValues
        .AutoFilter
        Application.CutCopyMode = [color=darkblue]False[/color]
    [color=darkblue]End[/color] [color=darkblue]With[/color]
    
[color=darkblue]End[/color] [color=darkblue]Sub[/color]

Icesurf3r · May 26, 2016

Re: VBA: autofilter criteria

Thanks AlphaFrog,

Appreciate the help.

I have tried to modify the code slightly, as the button needs to be on a different worksheet to the actual data, so the code now reads:

Code:

Sub Yes()

If Worksheets("Initiative Tracker").FilterMode Then Worksheets("Initiative Tracker").ShowAllData

With Worksheets("Initiative Tracker").Range("A1").CurrentRegion
        .AutoFilter Field:=4, Criteria1:="Yes"
        Workbooks.Add xlWBATWorksheet
        .Copy
        Range("A1").PasteSpecial xlPasteAll
        Range("A1").PasteSpecial xlPasteValues
        .AutoFilter
        Application.CutCopyMode = False
    End With

End Sub

However I get a run-time error '1004': AutoFilter method of Range class failed for this line of code:

Code:

 .AutoFilter Field:=4, Criteria1:="Yes"

Not sure if this makes a difference, but the worksheet that holds the data is formatted as a table rather than just normal rows and columns. Please could you help.

By changing the AutoFilter Field and Criteria, I'm guessing I can make it look for a different word or phrase in a different column i.e. AutoFilter Field:= 9, Criteria1:="definition" it would search in column I for the word definition?

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

lakersbg

New Member

VBABEGINER

Well-known Member

Excel Facts

cindrella39

New Member

cindrella39

New Member

thedogg

Board Regular

AlphaFrog

MrExcel MVP

thedogg

Board Regular

beauty

New Member

Icesurf3r

New Member

AlphaFrog

MrExcel MVP

Icesurf3r

New Member

Similar threads

Forum statistics

Share this page

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

New Member

Well-known Member

Excel Facts

New Member

New Member

Board Regular

MrExcel MVP

Board Regular

New Member

New Member

MrExcel MVP

New Member

Similar threads

Forum statistics

Share this page

We've detected that you are using an adblocker.

Which adblocker are you using?

Disable AdBlock

Disable AdBlock Plus

Disable uBlock Origin

Disable uBlock