Macro to extract Columns based on multiple criteria

[sush23]

Hi there, I have a sheet within a workbook (with other sheets) that has multiple columns and gets updated every month with new data for the month that just closed (appended at the end). For any accountants out there, its a general ledger of transactions for the month, for just one account. Some of the columns within the sheet are generated from the ERP system some by me if I need to analyze something. I uploaded a sample file with dummy data. I was hoping I would get some help with a simple macro that extracts certain columns out of this data based on Criteria that the user would need to enter. The criteria would be in Column Y, Z and AF, which are the month, year and unique identifier, which is a concatenate of two other cells. I would need the data extracted and put in another sheet, preferably in a completely new workbook, but if two complicated the same workbook is fine and the columns I would need to extract are Col F-Q only. So the user would get prompted to enter the month, year and unique identifier and the macro would extract the data matching those criteria in Col F-Q into another sheet for the user. Would this be possible? I was playing around with the index, aggregate and row functions, but it was getting complicated as I need to add another unique identifier to capture all the criteria I want to extract, so I was hoping one of you excel rockstars could help me out. I highlighted to col to be extracted in yellow and criteria columns in green. I appreciate all your help.

Test file.xlsx
	B	C	D	E	F	G	H	I	J	K	L	M	N	O	P	Q	R	S	T	U	V	W	X	Y	Z	AA	AB	AC	AD	AE	AF	AG
3	GL Report	Entity	Account	Description	Sub Account	Description	JE Type	JE Type	Batch Number	Period Entered	Reference	Transaction Date	Description	Debit	Credit	Net	Other Data	Other Data	Other Data	Other Data	Other Data	Other Data	Other Data	Other Data	Month	Year	Other Data	Other Data	Other Data	Other Data	Other Data	Unique Identifier
4	6/30/2021	A	1234	Due from Company	ABC	Company B	GJ	GL	7890	6/1/2021	TAX	6/4/2021	meeting	425.00	0	425	abc	abc	abc	abc	abc	abc	abc	abc	6	2021	abc	abc	abc	abc	abc	A - ABC
5	6/30/2021	A	1234	Due from Company	ABC	Company B	GJ	GL	7891	6/2/2021	REIMB	6/5/2021	travel	11	0	11	abc	abc	abc	abc	abc	abc	abc	abc	6	2021	abc	abc	abc	abc	abc	A - ABC
6	6/30/2021	A	1234	Due from Company	ABC	Company B	GJ	GL	7892	6/3/2021	123	6/6/2021	taxi	45	0	45	abc	abc	abc	abc	abc	abc	abc	abc	6	2021	abc	abc	abc	abc	abc	A - ABC
7	6/30/2021	A	1234	Due from Company	ABC	Company B	GJ	GL	7893	6/4/2021	APR CC	6/7/2021	hotel	6	0	6	abc	abc	abc	abc	abc	abc	abc	abc	6	2021	abc	abc	abc	abc	abc	A - ABC
8	6/30/2021	A	1234	Due from Company	DEF	Conpany D	GJ	GL	7894	6/5/2021	567	6/8/2021	ABC	73	0	73	abc	abc	abc	abc	abc	abc	abc	abc	6	2021	abc	abc	abc	abc	abc	A - DEF
9	6/30/2021	A	1234	Due from Company	DEF	Conpany D	GJ	GL	7895	6/6/2021	TAX	6/9/2021	meeting	5678	0	5678	abc	abc	abc	abc	abc	abc	abc	abc	6	2021	abc	abc	abc	abc	abc	A - DEF
10	6/30/2021	B	1234	Due from Company	DEF	Conpany D	GJ	GL	7896	6/7/2021	PMT	6/10/2021	travel	24467	0	24467	abc	abc	abc	abc	abc	abc	abc	abc	6	2021	abc	abc	abc	abc	abc	B - DEF
11	6/30/2021	B	1234	Due from Company	DEF	Conpany D	GJ	GL	7897	6/8/2021	PMT	6/11/2021	taxi	12	0	12	abc	abc	abc	abc	abc	abc	abc	abc	6	2021	abc	abc	abc	abc	abc	B - DEF
12	6/30/2021	B	1234	Due from Company	GHI	Company E	GJ	GL	7898	6/9/2021	PMT	6/12/2021	hotel	75	0	75	abc	abc	abc	abc	abc	abc	abc	abc	6	2021	abc	abc	abc	abc	abc	B - GHI
13	6/30/2021	B	1234	Due from Company	GHI	Company E	GJ	GL	7899	6/10/2021	PMT	6/13/2021	ABC	8	8	0	abc	abc	abc	abc	abc	abc	abc	abc	6	2021	abc	abc	abc	abc	abc	B - GHI
14	6/30/2021	B	1234	Due from Company	GHI	Company E	GJ	GL	7900	6/11/2021	TAX	6/14/2021	meeting	23	2342	-2319	abc	abc	abc	abc	abc	abc	abc	abc	6	2021	abc	abc	abc	abc	abc	B - GHI
15	6/30/2021	B	1234	Due from Company	GHI	Company E	GJ	GL	7901	6/12/2021	PRO FEE	6/15/2021	travel	8	35	-27	abc	abc	abc	abc	abc	abc	abc	abc	6	2021	abc	abc	abc	abc	abc	B - GHI
16	6/30/2021	B	1234	Due from Company	GHI	Company E	GJ	GL	7902	6/13/2021	PRO FEE	6/16/2021	taxi	4	6	-2	abc	abc	abc	abc	abc	abc	abc	abc	6	2021	abc	abc	abc	abc	abc	B - GHI
17	6/30/2021	B	1234	Due from Company	GHI	Company E	GJ	GL	7903	6/14/2021	PRO FEE	6/17/2021	hotel	14	0	14	abc	abc	abc	abc	abc	abc	abc	abc	6	2021	abc	abc	abc	abc	abc	B - GHI
18	6/30/2021	B	1234	Due from Company	GHI	Company E	GJ	GL	7904	6/15/2021	PRO FEE	6/18/2021	ABC	65	0	65	abc	abc	abc	abc	abc	abc	abc	abc	6	2021	abc	abc	abc	abc	abc	B - GHI
19	7/31/2021	A	1234	Due from Company	ABC	Company B	GJ	GL	7905	7/1/2021	PRO FEE	7/8/2021	meeting	6	0	6	abc	abc	abc	abc	abc	abc	abc	abc	7	2021	abc	abc	abc	abc	abc	A - ABC
20	7/31/2021	A	1234	Due from Company	ABC	Company B	GJ	GL	7906	7/2/2021	PRO FEE	7/9/2021	travel	83	0	83	abc	abc	abc	abc	abc	abc	abc	abc	7	2021	abc	abc	abc	abc	abc	A - ABC
21	7/31/2021	A	1234	Due from Company	ABC	Company B	GJ	GL	7907	7/3/2021	PRO FEE	7/10/2021	taxi	53	0	53	abc	abc	abc	abc	abc	abc	abc	abc	7	2021	abc	abc	abc	abc	abc	A - ABC
22	7/31/2021	A	1234	Due from Company	ABC	Company B	GJ	GL	7908	7/4/2021	MAR CC	7/11/2021	hotel	7	136	-129	abc	abc	abc	abc	abc	abc	abc	abc	7	2021	abc	abc	abc	abc	abc	A - ABC
23	7/31/2021	A	1234	Due from Company	DEF	Conpany D	GJ	GL	7909	7/5/2021	MAR CC	7/12/2021	ABC	23	0	23	abc	abc	abc	abc	abc	abc	abc	abc	7	2021	abc	abc	abc	abc	abc	A - DEF
24	7/31/2021	A	1234	Due from Company	DEF	Conpany D	GJ	GL	7910	7/6/2021	MAR CC	7/13/2021	meeting	53	83	-30	abc	abc	abc	abc	abc	abc	abc	abc	7	2021	abc	abc	abc	abc	abc	A - DEF
25	7/31/2021	A	1234	Due from Company	DEF	Conpany D	GJ	GL	7911	7/7/2021	MAR CC	7/14/2021	travel	567	0	567	abc	abc	abc	abc	abc	abc	abc	abc	7	2021	abc	abc	abc	abc	abc	A - DEF
26	7/31/2021	B	1234	Due from Company	DEF	Conpany D	GJ	GL	7912	7/8/2021	MAR CC	7/15/2021	taxi	2	0	2	abc	abc	abc	abc	abc	abc	abc	abc	7	2021	abc	abc	abc	abc	abc	B - DEF
27	7/31/2021	B	1234	Due from Company	GHI	Company E	GJ	GL	7913	7/9/2021	MAR CC	7/16/2021	hotel	53	0	53	abc	abc	abc	abc	abc	abc	abc	abc	7	2021	abc	abc	abc	abc	abc	B - GHI
28	7/31/2021	B	1234	Due from Company	GHI	Company E	GJ	GL	7914	7/10/2021	MAR CC	7/17/2021	ABC	76	0	76	abc	abc	abc	abc	abc	abc	abc	abc	7	2021	abc	abc	abc	abc	abc	B - GHI
29	7/31/2021	B	1234	Due from Company	GHI	Company E	GJ	GL	7915	7/11/2021	MAR CC	7/18/2021	meeting	78989	0	78989	abc	abc	abc	abc	abc	abc	abc	abc	7	2021	abc	abc	abc	abc	abc	B - GHI
30	7/31/2021	B	1234	Due from Company	GHI	Company E	GJ	GL	7916	7/12/2021	2/21/2021	7/19/2021	travel	234	0	234	abc	abc	abc	abc	abc	abc	abc	abc	7	2021	abc	abc	abc	abc	abc	B - GHI
31	7/31/2021	B	1234	Due from Company	GHI	Company E	GJ	GL	7917	7/13/2021	2/21/2021	7/20/2021	taxi	345	0	345	abc	abc	abc	abc	abc	abc	abc	abc	7	2021	abc	abc	abc	abc	abc	B - GHI
32	7/31/2021	B	1234	Due from Company	GHI	Company E	GJ	GL	7918	7/14/2021	2/21/2021	7/21/2021	hotel	5435	0	5435	abc	abc	abc	abc	abc	abc	abc	abc	7	2021	abc	abc	abc	abc	abc	B - GHI
33	8/31/2021	A	1234	Due from Company	ABC	Company B	GJ	GL	7919	8/1/2021	6/21/2021	8/10/2021	ABC	1246.00	0	1246	abc	abc	abc	abc	abc	abc	abc	abc	8	2021	abc	abc	abc	abc	abc	A - ABC
34	8/31/2021	A	1234	Due from Company	ABC	Company B	GJ	GL	7920	8/1/2021	6/21/2021	8/11/2021	meeting	23	0	23	abc	abc	abc	abc	abc	abc	abc	abc	8	2021	abc	abc	abc	abc	abc	A - ABC
35	8/31/2021	A	1234	Due from Company	ABC	Company B	GJ	GL	7921	8/1/2021	6/21/2021	8/12/2021	travel	53	0	53	abc	abc	abc	abc	abc	abc	abc	abc	8	2021	abc	abc	abc	abc	abc	A - ABC
36	8/31/2021	A	1234	Due from Company	ABC	Company B	GJ	GL	7922	8/1/2021	REIMB	8/13/2021	taxi	46	0	46	abc	abc	abc	abc	abc	abc	abc	abc	8	2021	abc	abc	abc	abc	abc	A - ABC
37	8/31/2021	A	1234	Due from Company	DEF	Conpany D	GJ	GL	7923	8/1/2021	6/21/2021	8/14/2021	hotel	57	0	57	abc	abc	abc	abc	abc	abc	abc	abc	8	2021	abc	abc	abc	abc	abc	A - DEF
38	8/31/2021	A	1234	Due from Company	DEF	Conpany D	GJ	GL	7924	8/1/2021	6/21/2021	8/15/2021	ABC	23	0	23	abc	abc	abc	abc	abc	abc	abc	abc	8	2021	abc	abc	abc	abc	abc	A - DEF
39	8/31/2021	A	1234	Due from Company	DEF	Conpany D	GJ	GL	7925	8/1/2021	6/21/2021	8/16/2021	meeting	32	0	32	abc	abc	abc	abc	abc	abc	abc	abc	8	2021	abc	abc	abc	abc	abc	A - DEF
40	8/31/2021	A	1234	Due from Company	DEF	Conpany D	GJ	GL	7926	8/1/2021	PRO FEE	8/17/2021	travel	5	0	5	abc	abc	abc	abc	abc	abc	abc	abc	8	2021	abc	abc	abc	abc	abc	A - DEF
41	8/31/2021	A	1234	Due from Company	GHI	Company E	GJ	GL	7927	8/1/2021	PMT	8/18/2021	taxi	2	0	2	abc	abc	abc	abc	abc	abc	abc	abc	8	2021	abc	abc	abc	abc	abc	A - GHI
42	8/31/2021	A	1234	Due from Company	GHI	Company E	GJ	GL	7928	8/1/2021	PMT	8/19/2021	hotel	42	0	42	abc	abc	abc	abc	abc	abc	abc	abc	8	2021	abc	abc	abc	abc	abc	A - GHI
43	8/31/2021	B	1234	Due from Company	GHI	Company E	GJ	GL	7929	8/1/2021	PMT	8/20/2021	ABC	53	0	53	abc	abc	abc	abc	abc	abc	abc	abc	8	2021	abc	abc	abc	abc	abc	B - GHI
44	8/31/2021	B	1234	Due from Company	GHI	Company E	GJ	GL	7930	8/1/2021	PMT	8/21/2021	meeting	24	0	24	abc	abc	abc	abc	abc	abc	abc	abc	8	2021	abc	abc	abc	abc	abc	B - GHI
45	8/31/2021	B	1234	Due from Company	GHI	Company E	GJ	GL	7931	8/1/2021		8/22/2021	travel	31	0	31	abc	abc	abc	abc	abc	abc	abc	abc	8	2021	abc	abc	abc	abc	abc	B - GHI
46	8/31/2021	B	1234	Due from Company	GHI	Company E	GJ	GL	7932	8/1/2021		8/23/2021	taxi	32	0	32	abc	abc	abc	abc	abc	abc	abc	abc	8	2021	abc	abc	abc	abc	abc	B - GHI
47	8/31/2021	B	1234	Due from Company	KLM	Company F	GJ	GL	7933	8/1/2021	7/8/2020	8/24/2021	hotel	35	0	35	abc	abc	abc	abc	abc	abc	abc	abc	8	2021	abc	abc	abc	abc	abc	B - KLM
48	8/31/2021	B	1234	Due from Company	ABC	Company F	GJ	GL	7934	8/1/2021	REIMB	8/25/2021	ABC	133	0	133	abc	abc	abc	abc	abc	abc	abc	abc	8	2021	abc	abc	abc	abc	abc	B - ABC
49	8/31/2021	B	1234	Due from Company	ABC	Company F	GJ	GL	7935	8/1/2021	REVERSAL	8/26/2021	meeting	42	0	42	abc	abc	abc	abc	abc	abc	abc	abc	8	2021	abc	abc	abc	abc	abc	B - ABC
50	8/31/2021	B	1234	Due from Company	ABC	Company F	GJ	GL	7936	8/1/2021	PMT	8/27/2021	travel	43	0	43	abc	abc	abc	abc	abc	abc	abc	abc	8	2021	abc	abc	abc	abc	abc	B - ABC
51	8/31/2021	B	1234	Due from Company	ABC	Company F	GJ	GL	7937	8/1/2021	5/1/2021	8/28/2021	taxi	323412	0	323412	abc	abc	abc	abc	abc	abc	abc	abc	8	2021	abc	abc	abc	abc	abc	B - ABC
52	8/31/2021	B	1234	Due from Company	ABC	Company F	GJ	GL	7938	8/1/2021	78901	8/29/2021	hotel	3	0	3	abc	abc	abc	abc	abc	abc	abc	abc	8	2021	abc	abc	abc	abc	abc	B - ABC
Sheet1

Cell Formulas
Range	Formula
Z4:Z52	Z4	=MONTH(M4)
AA4:AA52	AA4	=YEAR(K4)
K5:K18,M34:M52,J5:J52,M20:M32,K20:K32,M5:M18	K5	=K4+1
Q4:Q52	Q4	=O4-P4
AG4:AG52	AG4	=CONCATENATE(C4," - ",F4)

 

[Trebor76]

Hi sush23,

Try this:

Option Explicit
Sub Macro1()

    Dim strUserCriteria() As String
    Dim ws As Worksheet
    Dim lngLastRow As Long
    Dim wbActive As Workbook, wbNew As Workbook
    
    Set wbActive = ThisWorkbook
    Set ws = wbActive.Sheets("Sheet1") 'Sheet name containing GL data. Change to suit if necessary.
    
    On Error Resume Next
        If WorksheetFunction.CountA(ws.Cells) > 0 Then
            lngLastRow = ws.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
            If lngLastRow < 4 Then
                MsgBox "There doesn't appear to be any data on """ & ws.Name & """ to work with." & vbNewLine & "Please check and try again.", vbExclamation
                Exit Sub
            End If
        End If
    On Error GoTo 0
    
    ws.AutoFilterMode = False 'Remove all filters
    strUserCriteria = Split(InputBox("Enter the month, year and unique identifier (each separated via comma) you'd like to extract matching records for e.g." & vbNewLine & "6,2021,A - ABC", "Extract Records Editor"), ",")
    If UBound(strUserCriteria) < 2 Then
        Exit Sub 'User either pressed Cancel or did not make a proper entry
    End If
    
    Application.ScreenUpdating = False
    
    ws.Range("$B$3:$AG$" & lngLastRow).AutoFilter Field:=25, Criteria1:=strUserCriteria(0), Operator:=xlAnd
    ws.Range("$B$3:$AG$" & lngLastRow).AutoFilter Field:=26, Criteria1:=strUserCriteria(1), Operator:=xlAnd
    ws.Range("$B$3:$AG$" & lngLastRow).AutoFilter Field:=32, Criteria1:=strUserCriteria(2), Operator:=xlAnd
    
    If Application.WorksheetFunction.Subtotal(103, ws.Range("$B$3:$B$" & lngLastRow).Offset(1, 0)) > 0 Then
        Set wbNew = Workbooks.Add(1) 'Create a new workbook with just one sheet. Change to suit if necessaty.
        ws.Range("$B$3:$AG$" & lngLastRow).SpecialCells(xlCellTypeVisible).Copy Destination:=wbNew.Sheets(1).Range("A1")
        wbActive.Activate
        MsgBox "The matching " & Format(Application.WorksheetFunction.Subtotal(103, ws.Range("$B$3:$B$" & lngLastRow).Offset(1, 0)), "#,##0") & " record(s) have now been copied to a new workbook.", vbInformation
    Else
        MsgBox "There were no matching records found.", vbExclamation
    End If
    
    ws.AutoFilterMode = False 'Remove all filters
    
    Application.ScreenUpdating = True

End Sub

Regards,

Robert

 

[Trebor76]

Just remembered you only wanted columns F to Q (inclusive)

To copy just those 12 columns change this line...

ws.Range("$B$3:$AG$" & lngLastRow).SpecialCells(xlCellTypeVisible).Copy Destination:=wbNew.Sheets(1).Range("A1")

...to this:

ws.Range("$F$3:$Q$" & lngLastRow).SpecialCells(xlCellTypeVisible).Copy Destination:=wbNew.Sheets(1).Range("A1")

 

[sush23]

Thanks Trebor 76! Much appreciate your help. Unfortunately, it's giving me an error: Autofilter Method of Range class failed. The debugger goes straight to the lines I replaced with then new code in your second post.

I actually put together the below code yesterday, which works well (I apologize in advance, my code writing is rudimentary at best, but wanted to give it a shot). It basically followed the steps I would take if I were to use the Advanced Filter tool in Excel manually and tried to automate it with a button to make it easier on the user. The user enters the conditions in a separate tab, presses an ACTIVEX button and the code filters and pastes the data into another sheet. The slight annoyances with the code are

1) As soon as I extract the data, the tab the data comes from removes the filters option and I need to constantly go back to the master tab and put the filters on (ALT - A - T). Its not a problem that it unfilters the data, its annoying when it removes the function completely.
2) Would it be possible to add something to this code that pastes the extracted data in a new workbook, so the user doesn't have to copy the tab into another workbook and save it separately each time

Again, appreciate it
Rachel

Private Sub CommandButton1_Click ()
Sheet3.Activate
Sheet3.Range("F3:Q3").Select
Selection.Copy
Sheet4.Select
Sheet4.Range("A1:L1").pastespecial
Sheet4.Columns("A:L").EntireColumn.Autofit
Sheet4.Range("S1").Select
Sheet3.Select
Application.Cutcopymode=False
Sheet3.Range("F10").Select
Sheet4.Select
Sheet3.Range("B3:AK5000").Advancedfilter Action:clFiltercopy, criteriarange:=Sheet1.Range("c5:e6"), copytorange:=Sheet4.Range("A1:L1"), Unique:=False
End Sub

 

[Trebor76]

Thanks Trebor 76! Much appreciate your help. Unfortunately, it's giving me an error: Autofilter Method of Range class failed. The debugger goes straight to the lines I replaced with then new code in your second post.

That's odd as it worked for me

I actually put together the below code yesterday, which works well

That surprises me a little as there is no clFiltercopy argument for the AdvancedFilter syntax - it is xlFiltercopy. This is a great example of why you should always use Option Explicit. Also the text "Month" in cell Z3 of Sheet3 had a trailing space so it was "Month " which meant the criteria did not work as expected (that may have been a result of copying the data down I must say).

I have written two macros - the first (Macro2) keeps clearing the data in Sheet4 before it pastes the new filter data. The second (Macro3) pastes the results in a newly created workbook with a single sheet but in my humble opinion (unless there's a specific reason for it) I would not do this as there could be numerous workbooks created during the data being analyzed. Both macros remove the advanced filter and then puts filters back on the main data set (I think that's what you're asking for in 1 above).

Robert

'https://www.mrexcel.com/board/threads/macro-to-extract-columns-based-on-multiple-criteria.1183988/
Option Explicit
Sub Macro2()

    Dim lngLastRow As Long
    Dim rngData As Range, rngCriteria As Range, rngFiltered As Range, rngOutput As Range
    
    Application.ScreenUpdating = False
    
    lngLastRow = Sheet3.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    
    Set rngData = Sheet3.Range("B3:AG" & lngLastRow)
    Set rngCriteria = Sheet1.Range("C5:E6") 'C5:E5 are the headings to be filtered, C6:E6 are the criteria
    Set rngOutput = Sheet4.Range("A1")
    
    rngData.AdvancedFilter Action:=xlFilterInPlace, CriteriaRange:=rngCriteria
    Set rngFiltered = Sheet3.Range("$F$3:$Q$" & lngLastRow).SpecialCells(xlCellTypeVisible)
    Sheet4.Cells.ClearContents 'Clear any existing filtered data in output 'Sheet4'
    rngFiltered.Copy Destination:=rngOutput
    
    Sheet3.AutoFilterMode = False 'Remove all filters
    rngData.AutoFilter 'Put a filter on first row
    
    Application.ScreenUpdating = True

End Sub
Sub Macro3()

    Dim lngLastRow As Long
    Dim rngData As Range, rngCriteria As Range, rngFiltered As Range
    Dim wbOutput As Workbook
    
    Application.ScreenUpdating = False
    
    lngLastRow = Sheet3.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    
    Set rngData = Sheet3.Range("B3:AG" & lngLastRow)
    Set rngCriteria = Sheet1.Range("C5:E6") 'C5:E5 are the headings to be filtered, C6:E6 are the criteria
        
    rngData.AdvancedFilter Action:=xlFilterInPlace, CriteriaRange:=rngCriteria
    Set rngFiltered = Sheet3.Range("$F$3:$Q$" & lngLastRow).SpecialCells(xlCellTypeVisible)
    
    Set wbOutput = Workbooks.Add(1) 'Create a new workbook with just one sheet. Change to suit if necessaty.
    rngFiltered.Copy Destination:=wbOutput.Sheets(1).Range("A1")
    
    Sheet3.AutoFilterMode = False 'Remove all filters
    rngData.AutoFilter 'Put a filter on first row
    
    Application.ScreenUpdating = True

End Sub

 

[sush23]

That's odd as it worked for me



That surprises me a little as there is no clFiltercopy argument for the AdvancedFilter syntax - it is xlFiltercopy. This is a great example of why you should always use Option Explicit. Also the text "Month" in cell Z3 of Sheet3 had a trailing space so it was "Month " which meant the criteria did not work as expected (that may have been a result of copying the data down I must say).

I have written two macros - the first (Macro2) keeps clearing the data in Sheet4 before it pastes the new filter data. The second (Macro3) pastes the results in a newly created workbook with a single sheet but in my humble opinion (unless there's a specific reason for it) I would not do this as there could be numerous workbooks created during the data being analyzed. Both macros remove the advanced filter and then puts filters back on the main data set (I think that's what you're asking for in 1 above).

Robert

'https://www.mrexcel.com/board/threads/macro-to-extract-columns-based-on-multiple-criteria.1183988/
Option Explicit
Sub Macro2()

    Dim lngLastRow As Long
    Dim rngData As Range, rngCriteria As Range, rngFiltered As Range, rngOutput As Range
   
    Application.ScreenUpdating = False
   
    lngLastRow = Sheet3.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
   
    Set rngData = Sheet3.Range("B3:AG" & lngLastRow)
    Set rngCriteria = Sheet1.Range("C5:E6") 'C5:E5 are the headings to be filtered, C6:E6 are the criteria
    Set rngOutput = Sheet4.Range("A1")
   
    rngData.AdvancedFilter Action:=xlFilterInPlace, CriteriaRange:=rngCriteria
    Set rngFiltered = Sheet3.Range("$F$3:$Q$" & lngLastRow).SpecialCells(xlCellTypeVisible)
    Sheet4.Cells.ClearContents 'Clear any existing filtered data in output 'Sheet4'
    rngFiltered.Copy Destination:=rngOutput
   
    Sheet3.AutoFilterMode = False 'Remove all filters
    rngData.AutoFilter 'Put a filter on first row
   
    Application.ScreenUpdating = True

End Sub
Sub Macro3()

    Dim lngLastRow As Long
    Dim rngData As Range, rngCriteria As Range, rngFiltered As Range
    Dim wbOutput As Workbook
   
    Application.ScreenUpdating = False
   
    lngLastRow = Sheet3.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
   
    Set rngData = Sheet3.Range("B3:AG" & lngLastRow)
    Set rngCriteria = Sheet1.Range("C5:E6") 'C5:E5 are the headings to be filtered, C6:E6 are the criteria
       
    rngData.AdvancedFilter Action:=xlFilterInPlace, CriteriaRange:=rngCriteria
    Set rngFiltered = Sheet3.Range("$F$3:$Q$" & lngLastRow).SpecialCells(xlCellTypeVisible)
   
    Set wbOutput = Workbooks.Add(1) 'Create a new workbook with just one sheet. Change to suit if necessaty.
    rngFiltered.Copy Destination:=wbOutput.Sheets(1).Range("A1")
   
    Sheet3.AutoFilterMode = False 'Remove all filters
    rngData.AutoFilter 'Put a filter on first row
   
    Application.ScreenUpdating = True

End Sub

Thanks Robert, You were right, I miss-spelled the code, it is xlfiltercopy. I am working on two computers and was typing my short code rather than pasting it. I understand your point on creating a new workbook. Let me try one of these codes and let you know. Again, THANK YOU

 

[Trebor76]

Hi sush23,

You're welcome

Since my last post I came across this video that shows a really nifty tip on how you can filter data for particular columns when using the advanced filter by the headings you enter into Row 1 of the output sheet (A1:L1 in Sheet4 from your case). As such I have written the following macro (just make sure your headings are in A1:L1 of Sheet4 before using):

'Original thread:
'https://www.mrexcel.com/board/threads/macro-to-extract-columns-based-on-multiple-criteria.1183988
'Filtering by column headers:
'https://www.youtube.com/watch?v=evrnIuDRtsQ
Option Explicit
Sub Macro4()

    Dim lngLastRow As Long
    Dim rngData As Range, rngCriteria As Range, rngFiltered As Range, rngOutput As Range
    
    Application.ScreenUpdating = False
    
    'Clear any existing extract
    lngLastRow = Sheet4.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    If lngLastRow >= 2 Then
        Sheet4.Rows("2:" & lngLastRow).Delete
    End If
    
    'Filter and import new extract
    lngLastRow = Sheet3.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    Set rngData = Sheet3.Range("B3:AG" & lngLastRow)
    Set rngCriteria = Sheet1.Range("C5:E6") 'C5:E5 are the headings to be filtered, C6:E6 are the criteria
    Set rngOutput = Sheet4.Range("A1:L1") 'Extract columns by header in A1:L1. Source:https://www.youtube.com/watch?v=evrnIuDRtsQ
    
    rngData.AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=rngCriteria, CopyToRange:=rngOutput, Unique:=False
    Sheet4.Columns("A:L").EntireColumn.AutoFit
    
    Sheet3.AutoFilterMode = False 'Remove all filters
    rngData.AutoFilter 'Put a filter on first row
    
    Application.ScreenUpdating = True

End Sub

Regards,

Robert