VBA code to copy data based on criteria

[spvsr999]

Hi There,

I am looking for a VBA code that can copy all the rows (Incl Headers) based on criteria in specific column.

Scenario :-

I have a File with 8 different sheets and different information. Commonly, every sheet has a "Status" column.
I want to filter the status column and check for "Completed" and Paste special (Values & Formats) into a new workbook (Ready to save), new sheet with the Sheet name from the source file.

Example :-
Base file
Sheet Name is New Assignments --- There are 300+ records --- filtering on Status column (Column N) will give me 45 records.
Another Sheet name is Transfers --- There are 140+ records -- Filtering on Status Column (Column I) will give me 10 records

I want this the filtered lines into a new workbook

45 records + Headers into a new Worksheet with the sheet name -- New assignments
10 records + Headers into a new Worksheet with the sheet name -- Transfers

Thank you in advance for the help.

 

[mumps]

Try:

Sub CopyData()
    Application.ScreenUpdating = False
    Dim ws1 As Worksheet, ws2 As Worksheet
    Set ws1 = ThisWorkbook.Sheets("New Assignments")
    Set ws2 = ThisWorkbook.Sheets("Tranfers")
    Workbooks.Add
    With ws1
        .Range("A1").AutoFilter 14, "Completed"
        .AutoFilter.Range.Copy
        With Sheets(1)
            .Range("A1").PasteSpecial xlPasteValues
            .Range("A1").PasteSpecial xlPasteFormats
            .Name = ws1.Name
        End With
        .Range("A1").AutoFilter
    End With
    With ws2
        .Range("A1").AutoFilter 14, "Completed"
        .AutoFilter.Range.Copy
        With Sheets(2)
            .Range("A1").PasteSpecial xlPasteValues
            .Range("A1").PasteSpecial xlPasteFormats
            .Name = ws2.Name
        End With
        .Range("A1").AutoFilter
    End With
    Application.ScreenUpdating = True
End Sub

 

[spvsr999]

Try:

Sub CopyData()
    Application.ScreenUpdating = False
    Dim ws1 As Worksheet, ws2 As Worksheet
    Set ws1 = ThisWorkbook.Sheets("New Assignments")
    Set ws2 = ThisWorkbook.Sheets("Tranfers")
    Workbooks.Add
    With ws1
        .Range("A1").AutoFilter 14, "Completed"
        .AutoFilter.Range.Copy
        With Sheets(1)
            .Range("A1").PasteSpecial xlPasteValues
            .Range("A1").PasteSpecial xlPasteFormats
            .Name = ws1.Name
        End With
        .Range("A1").AutoFilter
    End With
    With ws2
        .Range("A1").AutoFilter 14, "Completed"
        .AutoFilter.Range.Copy
        With Sheets(2)
            .Range("A1").PasteSpecial xlPasteValues
            .Range("A1").PasteSpecial xlPasteFormats
            .Name = ws2.Name
        End With
        .Range("A1").AutoFilter
    End With
    Application.ScreenUpdating = True
End Sub

Thank you very much for this.

However, while trying to run the script I am getting the below error

And when trying to Debug, it is pointing at " With Sheets(2) " in the code.

Hope you can help through this as well.

 

[mumps]

How many sheets do you have in your workbook?

 

[spvsr999]

How many sheets do you have in your workbook?

There are 8 sheets of data and 3 hidden sheets (if in case useful)

Also If you can kindly tweek the filters in each sheets to "Completed" and "Rejected" in statys column.. its would be of great use.

Thanking you once again ?

 

[spvsr999]

statys

Status*

 

[mumps]

Try:

Sub CopyData()
    Application.ScreenUpdating = False
    Dim ws1 As Worksheet, ws2 As Worksheet
    Set ws1 = ThisWorkbook.Sheets("New Assignments")
    Set ws2 = ThisWorkbook.Sheets("Tranfers")
    Workbooks.Add
    With ws1
        .Range("A1").AutoFilter 14, "Completed"
        .AutoFilter.Range.Copy
        Sheets.Add after:=Sheets(Sheets.Count)
        Range("A1").PasteSpecial xlPasteValues
        Range("A1").PasteSpecial xlPasteFormats
        ActiveSheet.Name = ws1.Name
        .Range("A1").AutoFilter
    End With
    With ws2
        .Range("A1").AutoFilter 14, "Rejected"
        .AutoFilter.Range.Copy
        Sheets.Add after:=Sheets(Sheets.Count)
        Range("A1").PasteSpecial xlPasteValues
        Range("A1").PasteSpecial xlPasteFormats
        ActiveSheet.Name = ws2.Name
        .Range("A1").AutoFilter
    End With
    Application.ScreenUpdating = True
End Sub

 

[spvsr999]

Try:

Sub CopyData()
    Application.ScreenUpdating = False
    Dim ws1 As Worksheet, ws2 As Worksheet
    Set ws1 = ThisWorkbook.Sheets("New Assignments")
    Set ws2 = ThisWorkbook.Sheets("Tranfers")
    Workbooks.Add
    With ws1
        .Range("A1").AutoFilter 14, "Completed"
        .AutoFilter.Range.Copy
        Sheets.Add after:=Sheets(Sheets.Count)
        Range("A1").PasteSpecial xlPasteValues
        Range("A1").PasteSpecial xlPasteFormats
        ActiveSheet.Name = ws1.Name
        .Range("A1").AutoFilter
    End With
    With ws2
        .Range("A1").AutoFilter 14, "Rejected"
        .AutoFilter.Range.Copy
        Sheets.Add after:=Sheets(Sheets.Count)
        Range("A1").PasteSpecial xlPasteValues
        Range("A1").PasteSpecial xlPasteFormats
        ActiveSheet.Name = ws2.Name
        .Range("A1").AutoFilter
    End With
    Application.ScreenUpdating = True
End Sub

Finally, the below code is working ... Thanks man !! ... Thank you very much .. You made my work a bit simpler ...

Sub CopyData()
Application.ScreenUpdating = False
Dim ws1 As Worksheet, ws2 As Worksheet
Set ws1 = ThisWorkbook.Sheets("New Assignments")
Set ws2 = ThisWorkbook.Sheets("Transfers")
Workbooks.Add
With ws1
.Range("A1").AutoFilter 14, "Completed"
.AutoFilter.Range.Copy
Sheets.Add after:=Sheets(Sheets.Count)
Range("A1").PasteSpecial xlPasteValues
Range("A1").PasteSpecial xlPasteFormats
ActiveSheet.Name = ws1.Name
.Range("A1").AutoFilter
End With
With ws2
.Range("A1").AutoFilter 18, "Completed"
.AutoFilter.Range.Copy
Sheets.Add after:=Sheets(Sheets.Count)
Range("A1").PasteSpecial xlPasteValues
Range("A1").PasteSpecial xlPasteFormats
ActiveSheet.Name = ws2.Name
.Range("A1").AutoFilter
End With
Application.ScreenUpdating = True
End Sub


Can you tell me how to add another criterion, I mean in the same column where the filter is there "Status" Column to give output for both "Completed" & "Pending"...!!

Thanks for everything !!!

 

[mumps]

Replace this line of code:

.Range("A1").AutoFilter 14, "Completed"

with this one:

.Range("A1").AutoFilter 14, Criteria1:="Completed", Operator:=xlAnd, Criteria2:="Pending"

 

[spvsr999]

Replace this line of code:

.Range("A1").AutoFilter 14, "Completed"

with this one:

.Range("A1").AutoFilter 14, Criteria1:="Completed", Operator:=xlAnd, Criteria2:="Pending"

No, if I change, the output is coming as headers ONLY and no data is being picked ..!!