• Hi All

    Please note that at the Chandoo.org Forums there is Zero Tolerance to Spam

    Post Spam and you Will Be Deleted as a User

    Hui...

  • When starting a new post, to receive a quicker and more targeted answer, Please include a sample file in the initial post.

Use Advanced Filter

A

Abhijeet

Active Member
Hi

I have Data From the Data i want to pull Product Wise Data Product mention in Column C in Data Sheet. I use Advanced filter & i use macro for this.Please tell me any other way to do this & also i want result in New Work book please tell me how to do this
Code: 
Sub Macro1()
'
' Macro1 Macro
'

'
    Sheets("Data").Columns("A:D").AdvancedFilter Action:=xlFilterCopy, _
        CriteriaRange:=Sheets("Data").Range("F1:F2"), CopyToRange:=Range( _
        "Cookies!Extract"), Unique:=False
    Sheets("Bread").Select
    Range("F3").Select
    Sheets("Data").Columns("A:D").AdvancedFilter Action:=xlFilterCopy, _
        CriteriaRange:=Sheets("Data").Range("G1:G2"), CopyToRange:=Range( _
        "Bread!Extract"), Unique:=False
    Sheets("Milk").Select
    Sheets("Data").Columns("A:D").AdvancedFilter Action:=xlFilterCopy, _
        CriteriaRange:=Sheets("Data").Range("H1:H2"), CopyToRange:=Range("A1:D1") _
        , Unique:=False
End Sub
 

Attachments

  • Advanced Filter Macro Test.xlsm
    19.9 KB · Views: 3
Where exactly are we sending the information? You're example had several sheets...are we "sorting" the Data sheet into the other worksheets?

Either way, I'd probably use one of the macros here:
http://www.rondebruin.nl/win/s3/win006.htm

As they will tell you how to copy to either existing sheets in the current workbook, or to a new workbook.
 
Hi Luke

Thanks for Given Link but apart from Autofilter or Advanced filter any other way to do this macro.please tell me
 
Why? You've been given several efficient ways that work. Why keep looking for another?
 
Hi Luke M

Your Question is Valid but i want to learn how to built code in VBA thats why i ask u any other way to do this please tell me
 
There are always infinite number of ways to do things, it just starts taking more and more steps. You could write a loop code that searches each cell, see if it's a match, and then copies that over. As I said, would be longer and slower, but you could do it. Search the forum for some example on loops if you've forgotten/lost the previous loop examples.
 
I have this Code this match Headers then paste the Data please tell me Output i want to save in New Workbook what changes need to do in this

Code: 
Sub CopyData()

Dim PstRng As Range
Dim CopyRange As Range

Set CopyRange = Sheet1.UsedRange
With ActiveSheet

  'Where are we copying to
Set PstRng = Intersect(.UsedRange, .Range("1:1"))
  'Clear old data
.Range("2:" & .Rows.Count).EntireRow.ClearContents
  'Copy via Filter
CopyRange.AdvancedFilter xlFilterCopy, , PstRng
End With
'Clear contents of cells
CopyRange.ClearContents
MsgBox "Done"
End Sub
 
You need to create a new workbook, and then define PstRng as some range in the new workbooks's sheet. You currently have it pasting from Sheet1 into the ActiveSheet.
 
Hi Luke M

I tried to do this but i am unable to do this can u please tell me what changes need to do in this line & any other changes need to do please tell me
Set PstRng = Intersect(.UsedRange, .Range("1:1"))
 
I'm not sure what you tried before, but a few example lines might be:
Code: 
Dim wb As Workbook
'Add a workbook
Set wb = Workbooks.Add
'Define the range as first cell in first sheet
Set PstRng = wb.Worksheets(1).Range("A1")
 
So then, jsut copy what we filtered to a new workbook?
Code: 
Sub CopyData()

Dim PstRng As Range
Dim CopyRange As Range
Dim wb As Workbook

Set CopyRange = Sheet1.UsedRange
With ActiveSheet

  'Where are we copying to
Set PstRng = Intersect(.UsedRange, .Range("1:1"))
  'Clear old data
.Range("2:" & .Rows.Count).EntireRow.ClearContents
  'Copy via Filter
CopyRange.AdvancedFilter xlFilterCopy, , PstRng
Set wb = Workbooks.Add
PstRng.Copy wb.Worksheets(1).Range("a1")
End With
'Clear contents of cells
CopyRange.ClearContents
MsgBox "Done"
End Sub
 
Hi Luke M
Macro pull only headers in new workbook data not pull Data pull only in next sheet in same file. But unable to pull in new workbook
 
Dynamic Range
Code: 
Sub Cookies_Bread_Milk()

Dim CurrWB As String
Dim NewWB As String

CurrWB = ActiveWorkbook.Name

'Clear autofilter if it exists
On Error Resume Next
ActiveSheet.AutoFilterMode = False

'Create New WB
Workbooks.Add.Activate
NewWB = ActiveWorkbook.Name

'Rename New WB sheets
Worksheets(1).Name = "Cookies"
Worksheets(2).Name = "Bread"
Worksheets(3).Name = "Milk"

'Cookies Copy
Windows(CurrWB).Activate
Worksheets("Data").Select
Range("A1:D" & Cells(Rows.Count, "A").End(xlUp).Row).Select
Selection.AutoFilter
ActiveSheet.Range(Selection.Address).AutoFilter Field:=3, Criteria1:="=Cookies" _
, Operator:=xlAnd
Range("A1").Select
Range("A1:D" & Cells(Rows.Count, "A").End(xlUp).Row).Select
Selection.SpecialCells(xlCellTypeVisible).Select
Selection.Copy

'Cookies Paste
Windows(NewWB).Activate
Worksheets("Cookies").Select
Range("A1").Select
ActiveSheet.Paste
Application.CutCopyMode = False

'Bread Copy
Windows(CurrWB).Activate
Worksheets("Data").Select
ActiveSheet.AutoFilterMode = False
Range("A1:D" & Cells(Rows.Count, "A").End(xlUp).Row).Select
Selection.AutoFilter
ActiveSheet.Range(Selection.Address).AutoFilter Field:=3, Criteria1:="=Bread" _
    , Operator:=xlAnd
Range("A1").Select
Range("A1:D" & Cells(Rows.Count, "A").End(xlUp).Row).Select
Selection.SpecialCells(xlCellTypeVisible).Select
Selection.Copy

'Bread Paste
Windows(NewWB).Activate
Worksheets("Bread").Select
Range("A1").Select
ActiveSheet.Paste
Application.CutCopyMode = False

'Milk Copy
Windows(CurrWB).Activate
Worksheets("Data").Select
ActiveSheet.AutoFilterMode = False
Range("A1:D" & Cells(Rows.Count, "A").End(xlUp).Row).Select
Selection.AutoFilter

ActiveSheet.Range(Selection.Address).AutoFilter Field:=3, Criteria1:="=Milk" _
    , Operator:=xlAnd
Range("A1").Select
Range("A1:D" & Cells(Rows.Count, "A").End(xlUp).Row).Select
Selection.SpecialCells(xlCellTypeVisible).Select
Selection.Copy

'Milk Paste
Windows(NewWB).Activate
Worksheets("Milk").Select
Range("A1").Select
ActiveSheet.Paste
Application.CutCopyMode = False

'End Macro
Windows(CurrWB).Activate
ActiveSheet.AutoFilterMode = False
Windows(NewWB).Activate
MsgBox "Cookies, Bread & Milk copied to New Workbook", vbInformation, ""

End Sub
 
Last edited:
Oops. Change this:
Code: 
PstRng.Copy wb.Worksheets(1).Range("a1")
to this:
Code: 
PstRng.CurrentRegion.Copy wb.Worksheets(1).Range("a1")
 
You must log in or register to reply here.
Back
Top