Find Multiple criteria in a single column and paste data found in new worksheet

[baywoman2001]

I am new to forums and kind of desparate. I am trying to learn VBA and have an immediate need to solve an issue I have. I manage very large purchase history worksheets (+100K Rows each). I need a faster way to break down information. I have certain criteria I am looking to consolidate to prepare a mailing. Based on the order# I need to find 2 items from column E that match that order#. Here is an excerpt. If you notice an item was purchased but some returned. I want to filter the data and copy it to a new worksheet. Anyway I tried creating this code based on one I saw and am getting all kinds of errors. Please help if you can
Sub MultipleCriteria()
Dim R As Range
Dim WSR As Worksheet ' Consolidated Sheet
Selection.AutoFilter
ActiveSheet.Range("$A$1:$N$10850").AutoFilter Field:=5, Criteria1:="3 YR*", Operator:=xlAnd
ActiveSheet.Range("$A$1:$N$10850").AutoFilter Field:=5, Criteria1:="Marriott TC*"
With ActiveCell.CurrentRegion
Set R = Range(.Cells(1, 1), .Cells(.Cells.Count))
End With
R.Copy
Set WSR = Worksheets.Add(after:=Worksheets("sheet10"))
' Sheets("sheet5").Select
Range("A1").Activate
Do Until ActiveCell.Value = ""
ActiveCell.Offset(1, 0).Select
Loop
ActiveSheet.Paste
Application.CutCopyMode = False
End Sub

Order No	Marsha Code X2	Asset No	Inv Date	Material Description	Serial No	Quantity	Ship Name	Ship Street	SHIP_CITY
313187018	Abaco	819989	40610	MARRIOTT TC M58P USFF 3.00 6MB 2GB/160 V	1S6136A1UMJMPVD4	1	Abaco Club Rc Ltd. Operts Dept	6970 WALLIS RD UNIT 1C	WEST PALM BEACH
313187018	Abaco	819998	40610	MARRIOTT TC M58P USFF 3.00 6MB 2GB/160 V	1S6136A1UMJMPTY7	1	Abaco Club Rc Ltd. Operts Dept	6970 WALLIS RD UNIT 1C	WEST PALM BEACH
313996183	Abaco	216924	40879	MARRIOTT TC M91P SFF INTEL 3.1G 2GB 250G	1S7033A1UMJEDBAP	1	Abaco Club Rc Ltd. Operts Dept	6970 WALLIS RD UNIT 1C	WEST PALM BEACH
313996318	Abaco	216955	40879	MARRIOTT TC M91P SFF INTEL 3.1G 2GB 250G	1S7033A1UMJEDBGB	1	Abaco Club Rc Ltd. Operts Dept	6970 WALLIS RD UNIT 1C	WEST PALM BEACH
313996475	Abaco	216956	40879	MARRIOTT TC M91P SFF INTEL 3.1G 2GB 250G	1S7033A1UMJEDBTF	1	Abaco Club Rc Ltd. Operts Dept	6970 WALLIS RD UNIT 1C	WEST PALM BEACH
313791660	ABEBC		40812	3 YR HARD DRIVE HOT SWAP FEE FOR MARRIOT	(blank)	2	ABEBC-Courtyard by Marriott	2220 EMRICK BLVD	BETHLEHEM
313791660	ABEBC	213345	40812	MARRIOTT TC M91P USFF INTEL 2.5G 2GB 250	1S5067A1UMJBABAC	1	ABEBC-Courtyard by Marriott	2220 EMRICK BLVD	BETHLEHEM
313791660	ABEBC	213346	40812	MARRIOTT TC M91P USFF INTEL 2.5G 2GB 250	1S5067A1UMJBABAE	1	ABEBC-Courtyard by Marriott	2220 EMRICK BLVD	BETHLEHEM
313605031	ABECY		40764	3 YR HARD DRIVE HOT SWAP FEE FOR MARRIOT	(blank)	3	ABECY Courtyard By Marriott	2160 MOTEL DR	BETHLEHEM
313605031	ABECY	210738	40764	MARRIOTT TC M91P USFF INTEL 2.5G 2GB 250	1S5067A1UMJZLRD0	1	ABECY Courtyard By Marriott	2160 MOTEL DR	BETHLEHEM
313605031	ABECY	210739	40764	MARRIOTT TC M91P USFF INTEL 2.5G 2GB 250	1S5067A1UMJYCCR2	1	ABECY Courtyard By Marriott	2160 MOTEL DR	BETHLEHEM
313605031	ABECY	210740	40764	MARRIOTT TC M91P USFF INTEL 2.5G 2GB 250	1S5067A1UMJZLRD3	1	ABECY Courtyard By Marriott	2160 MOTEL DR	BETHLEHEM
313121375	Abicy	205419	40588	MARRIOTT TC M58P USFF 3.00 6MB 2GB/160 V	1S6136A1UMJKXHF8	1	Abicy - Courtyard By Marriott	4350 RIDGEMONT DR	ABILENE
313498113	Abqca	208919	40709	MARRIOTT TC M58P SFF 3.00 6MB 2X1GB/160	1S6234A1UMJVYBD0	1	Abqca - Courtyard By Marriott	1920 YALE BLVD SE	ALBUQUERQUE
313593965	Abqca	210448	40746	MARRIOTT TC M91P SFF INTEL 3.1G 2GB 250G	1S7033A1UMJZGEH2	1	Abqca - Courtyard By Marriott	1920 YALE BLVD SE	ALBUQUERQUE
313844166	Abqca		40843	3 YR HARD DRIVE HOT SWAP FEE FOR MARRIOT	(blank)	2	Abqca - Courtyard By Marriott	1920 YALE BLVD SE	ALBUQUERQUE
313844166	Abqca	214266	40843	MARRIOTT TC M91P USFF INTEL 2.5G 2GB 250	1S5067A1UMJCDALN	1	Abqca - Courtyard By Marriott	1920 YALE BLVD SE	ALBUQUERQUE
313844166	Abqca	214267	40843	MARRIOTT TC M91P USFF INTEL 2.5G 2GB 250	1S5067A1UMJBWDYW	1	Abqca - Courtyard By Marriott	1920 YALE BLVD SE	ALBUQUERQUE
313930263	Abqcy		40883	3 YR HARD DRIVE HOT SWAP FEE FOR MARRIOT	(blank)	2	Abqcy - Courtyard By Marriott	5151 JOURNAL CENTER BLVD NE	ALBUQUERQUE
313930263	Abqcy	217250	40883	MARRIOTT TC M91P USFF INTEL 2.5G 2GB 250	1S5067A1UMJDTVMG	1	Abqcy - Courtyard By Marriott	5151 JOURNAL CENTER BLVD NE	ALBUQUERQUE
313930263	Abqcy	217251	40883	MARRIOTT TC M91P USFF INTEL 2.5G 2GB 250	1S5067A1UMJDTVTR	1	Abqcy - Courtyard By Marriott	5151 JOURNAL CENTER BLVD NE	ALBUQUERQUE
313959019	Abqfa		40877	3 YR HARD DRIVE HOT SWAP FEE FOR MARRIOT	(blank)	1	Abqfa - Fairfield Inn By Marriott	2300 CENTRE AVE SE	ALBUQUERQUE
313452877	Abqri	208246	40690	MARRIOTT TC M58P SFF 3.00 6MB 2X1GB/160	1S6234A1UMJTPBA3	1	Abqri - Residence Inn By Marriott	3300 PROSPECT AVE NE	ALBUQUERQUE
313612272	Abqri		40751	3 YR HARD DRIVE HOT SWAP FEE FOR MARRIOT	(blank)	2	Abqri - Residence Inn By Marriott	3300 PROSPECT AVE NE	ALBUQUERQUE
313612272	Abqri	210825	40751	MARRIOTT TC M91P USFF INTEL 2.5G 2GB 250	1S5067A1UMJYCCN0	1	Abqri - Residence Inn By Marriott	3300 PROSPECT AVE NE	ALBUQUERQUE
313612272	Abqri	210829	40751	MARRIOTT TC M91P USFF INTEL 2.5G 2GB 250	1S5067A1UMJYCCP4	1	Abqri - Residence Inn By Marriott	3300 PROSPECT AVE NE	ALBUQUERQUE
313669178	Abqrn		40767	3 YR HARD DRIVE HOT SWAP FEE FOR MARRIOT	(blank)	2	Abqrn - Residence Inn By Marriott	4331 THE LANE AT 25 NE	ALBUQUERQUE
313669178	Abqrn	211773	40767	MARRIOTT TC M91P USFF INTEL 2.5G 2GB 250	1S5067A1UMJAHBTD	1	Abqrn - Residence Inn By Marriott	4331 THE LANE AT 25 NE	ALBUQUERQUE
313669178	Abqrn	211774	40767	MARRIOTT TC M91P USFF INTEL 2.5G 2GB 250	1S5067A1UMJAHBTA	1	Abqrn - Residence Inn By Marriott	4331 THE LANE AT 25 NE	ALBUQUERQUE
55235833	ABYFX		40847	MARRIOTT TC M91P USFF INTEL 2.5G 2GB 250	1S5067A1UMJBABCX	-1	ABYFX - Fairfield Inn By Marriott	2001 E 16TH AVE	CORDELE

<TBODY>
</TBODY>

 

[pplstuff]

With that much data, perhaps you should consider using Access instead of Excel. This is untested, but might be a better start...

Option Explicit
Sub test()
    
    Dim rCopy As Range
    Dim ws1 As Worksheet
    Dim ws2 As Worksheet
    
    Application.ScreenUpdating = False
    
    'Check range is selected
    If TypeName(Selection) <> "Range" Then
        Exit Sub
    End If
    
    'set variables
    Set ws1 = ActiveSheet
    Set rCopy = Selection
    
    
    With ws1
        'Remove autofilter
        .AutoFilterMode = False
        With rCopy
            'Set filter
            .AutoFilter field:=5, Criteria1:="3 YR*", Operator:=xlAnd, Criteria2:="Marriott TC*"
        End With
        'Remove autofilter
        .AutoFilterMode = False
    End With
    
    'Set new variables
    Set rCopy = rCopy.SpecialCells(xlCellTypeVisible)
    Set ws2 = Worksheets.Add(after:=Sheets(ThisWorkbook.Sheets.Count))
    
    'Copy visible cells to new sheet
    rCopy.Copy
    ws2.Activate
    ws2.Range("A1").Select
    ActiveSheet.Paste
    
    Application.ScreenUpdating = False
    Application.CutCopyMode = xlCopy
    
End Sub