Filter data and copy to new sheets

[Dave_george]

I am typing to makes changes to the below code. I have 4 different categories in column C. ( D002,D004,D005 and 2* codes). I want D002 and 2* in one sheet. D004 and D005 filtered in another sheet.

CUSTOMER_ID	Names	HUB	WAVE	CASES	VOLUME	WEIGHT	SEG	SHIPMENT_GROUP
1002​	n/a	D002	4​	584​	7.58​	3,284.79​	STD
1003​	n/a	D002	4​	680​	8.14​	4,063.38​	STD
1007​	n/a	D004	4​	607​	8.84​	5,798.22​	STD
1009​	n/a	D002	4​	207​	2.93​	1,332.82​	STD
1012​	n/a	D004	4​	1,147.00​	13.29​	4,930.20​	STD
1134​	n/a	D005	4​	152​	2.04​	779.16​	STD
1171​	n/a	D005	4​	365​	5.03​	1,605.54​	STD
1180​	n/a	D005	4​	139​	2.4​	740.93​	STD
1350​	n/a	D005	4​	688​	10.89​	7,074.39​	STD
1361​	n/a	D005	4​	265​	4.86​	1,356.40​	STD
1364​	n/a	D005	4​	401​	5.01​	2,080.61​	STD
1376​	n/a	D005	4​	162​	1.82​	686.26​	STD
1377​	n/a	D005	4​	409​	6.53​	3,500.15​	STD
2567​	n/a	2567​	4​	78​	0.93​	422.57​	STD
2605​	n/a	2605​	4​	370​	6.79​	2,482.73​	STD
2640​	n/a	2640​	4​	66​	2.04​	378.43​	STD
2641​	n/a	2641​	4​	68​	0.5​	292.69​	STD
2663​	n/a	2663​	4​	54​	0.52​	255.28​	STD
2695​	n/a	2695​	4​	54​	1.27​	279.84​	STD
2719​	n/a	2719​	4​	160​	4​	903.73​	STD
2722​	n/a	2722​	4​	748​	13.57​	6,164.86​	STD
2737​	n/a	2737​	4​	61​	0.45​	361.51​	STD

Public gsDataTbl As String
Public gcolCtry As Collection

Public Const kCtryCOL = "C"

Public Sub HUB_FILTER()
Dim sCtry
Dim wsTarg As Worksheet
Dim iCtryCol As Integer, i As Integer
gsDataTbl = ActiveSheet.Name
iCtryCol = Asc(kCtryCOL) - 64
CollectCountries
For i = 1 To gcolCtry.Count
    sCtry = gcolCtry(i)
  
      
    Selection.AutoFilter
    ActiveSheet.UsedRange.AutoFilter Field:=iCtryCol, Criteria1:=sCtry
    ActiveSheet.UsedRange.Select
    Range(kCtryCOL & "1").Activate
    Selection.Copy
  
    Sheets.Add After:=ActiveSheet
    Set wsTarg = ActiveSheet
    ActiveSheet.Paste
    Application.CutCopyMode = False
  
    wsTarg.Activate
    wsTarg.Name = sCtry
      
    Sheets(gsDataTbl).Select
    Selection.AutoFilter
Next
Set wsTarg = Nothing
Set gcolCtry = Nothing
End Sub

Private Sub CollectCountries()
Set gcolCtry = New Collection
Dim sCtry As String
    Columns(kCtryCOL & ":" & kCtryCOL).Select
    Selection.Copy
    Sheets.Add After:=ActiveSheet
    ActiveSheet.Paste
    Application.CutCopyMode = False
    ActiveSheet.Range("$A$1:$A$1000").RemoveDuplicates Columns:=1, Header:=xlYes
    Range("A2").Select
   
While ActiveCell.Value <> ""
    sCtry = ActiveCell.Value
    gcolCtry.Add sCtry, sCtry
  
    ActiveCell.Offset(1, 0).Select
Wend
  
    Sheets(gsDataTbl).Select
    Range("A1").Select

 

[dermie_72]

You could try this code instead: Let me know how it goes.

Sub Dave_george()
Dim LR As Long
Dim Startsheet As Worksheet
LR = ActiveSheet.Cells(Rows.Count, "A").End(xlUp).Row 'Choose a column that has data to the end to get the last row number change "A" to the column
Set Startsheet = ActiveSheet
Rows("1:1").Select
If ActiveSheet.AutoFilterMode = False Then
    Selection.AutoFilter
End If
ActiveSheet.Range("$A$1:$I$" & LR).AutoFilter Field:=3, Criteria1:=Array( _
    "2*", "D002") _
    , Operator:=xlFilterValues
Range("A1:I" & LR).SpecialCells(xlCellTypeVisible).Copy
Sheets.Add After:=ActiveSheet
ActiveSheet.Paste
Startsheet.Select
ActiveSheet.Range("$A$1:$I$" & LR).AutoFilter Field:=3, Criteria1:="=D004", _
    Operator:=xlOr, Criteria2:="=D005"
Range("A1:I" & LR).SpecialCells(xlCellTypeVisible).Copy
Sheets.Add After:=ActiveSheet
ActiveSheet.Paste
Set Startsheet = Nothing
End Sub

 

[kevin9999]

I note you have 2021 on your profile, in which case you could access the Filter function. So with this on Sheet1:

Book1
	A	B	C	D	E	F	G	H	I
1	CUSTOMER_ID	Names	HUB	WAVE	CASES	VOLUME	WEIGHT	SEG	SHIPMENT_GROUP
2	1002	n/a	D002	4	584	7.58	3,284.79	STD
3	1003	n/a	D002	4	680	8.14	4,063.38	STD
4	1007	n/a	D004	4	607	8.84	5,798.22	STD
5	1009	n/a	D002	4	207	2.93	1,332.82	STD
6	1012	n/a	D004	4	1,147.00	13.29	4,930.20	STD
7	1134	n/a	D005	4	152	2.04	779.16	STD
8	1171	n/a	D005	4	365	5.03	1,605.54	STD
9	1180	n/a	D005	4	139	2.4	740.93	STD
10	1350	n/a	D005	4	688	10.89	7,074.39	STD
11	1361	n/a	D005	4	265	4.86	1,356.40	STD
12	1364	n/a	D005	4	401	5.01	2,080.61	STD
13	1376	n/a	D005	4	162	1.82	686.26	STD
14	1377	n/a	D005	4	409	6.53	3,500.15	STD
15	2567	n/a	2567	4	78	0.93	422.57	STD
16	2605	n/a	2605	4	370	6.79	2,482.73	STD
17	2640	n/a	2640	4	66	2.04	378.43	STD
18	2641	n/a	2641	4	68	0.5	292.69	STD
19	2663	n/a	2663	4	54	0.52	255.28	STD
20	2695	n/a	2695	4	54	1.27	279.84	STD
21	2719	n/a	2719	4	160	4	903.73	STD
22	2722	n/a	2722	4	748	13.57	6,164.86	STD
23	2737	n/a	2737	4	61	0.45	361.51	STD
Sheet1

This on Sheet2:

Book1
	A	B	C	D	E	F	G	H	I
1	CUSTOMER_ID	Names	HUB	WAVE	CASES	VOLUME	WEIGHT	SEG	SHIPMENT_GROUP
2	1002	n/a	D002	4	584	7.58	3,284.79	STD
3	1003	n/a	D002	4	680	8.14	4,063.38	STD
4	1009	n/a	D002	4	207	2.93	1,332.82	STD
5	2567	n/a	2567	4	78	0.93	422.57	STD
6	2605	n/a	2605	4	370	6.79	2,482.73	STD
7	2640	n/a	2640	4	66	2.04	378.43	STD
8	2641	n/a	2641	4	68	0.5	292.69	STD
9	2663	n/a	2663	4	54	0.52	255.28	STD
10	2695	n/a	2695	4	54	1.27	279.84	STD
11	2719	n/a	2719	4	160	4	903.73	STD
12	2722	n/a	2722	4	748	13.57	6,164.86	STD
13	2737	n/a	2737	4	61	0.45	361.51	STD
Sheet2

Cell Formulas
Range	Formula
A2:I13	A2	=FILTER(Sheet1!A:I,(Sheet1!C:C="D002")+(LEFT(Sheet1!C:C,1)="2"),"")
Dynamic array formulas.

And this on Sheet3:

Book1
	A	B	C	D	E	F	G	H	I
1	CUSTOMER_ID	Names	HUB	WAVE	CASES	VOLUME	WEIGHT	SEG	SHIPMENT_GROUP
2	1007	n/a	D004	4	607	8.84	5,798.22	STD
3	1012	n/a	D004	4	1,147.00	13.29	4,930.20	STD
4	1134	n/a	D005	4	152	2.04	779.16	STD
5	1171	n/a	D005	4	365	5.03	1,605.54	STD
6	1180	n/a	D005	4	139	2.4	740.93	STD
7	1350	n/a	D005	4	688	10.89	7,074.39	STD
8	1361	n/a	D005	4	265	4.86	1,356.40	STD
9	1364	n/a	D005	4	401	5.01	2,080.61	STD
10	1376	n/a	D005	4	162	1.82	686.26	STD
11	1377	n/a	D005	4	409	6.53	3,500.15	STD
Sheet3

Cell Formulas
Range	Formula
A2:I11	A2	=FILTER(Sheet1!A:I,(Sheet1!C:C="D004")+(Sheet1!C:C="D005"),"")
Dynamic array formulas.

 

[kevin9999]

Alternative code if you really want a VBA solution:

Option Explicit
Sub Filter_Copy()
    Dim ws1 As Worksheet, ws2 As Worksheet, ws3 As Worksheet
    Set ws1 = Worksheets("Sheet1")          '<--- *** Change sheet names to suit ***
    Set ws2 = Worksheets("Sheet2")
    Set ws3 = Worksheets("Sheet3")
    
    With ws1
        If .AutoFilterMode Then .AutoFilter.ShowAllData
        With .Range("A1").CurrentRegion
            .AutoFilter 3, "D002", 2, "2*"
            If WorksheetFunction.Subtotal(3, .Columns(1)) > 1 Then
                .Copy ws2.Range("A1")
            End If
            .AutoFilter 3, "D004", 2, "D005"
            If WorksheetFunction.Subtotal(3, .Columns(1)) > 1 Then
                .Copy ws3.Range("A1")
            End If
            .AutoFilter
        End With
    End With
End Sub

 

[Dave_george]

You could try this code instead: Let me know how it goes.

Sub Dave_george()
Dim LR As Long
Dim Startsheet As Worksheet
LR = ActiveSheet.Cells(Rows.Count, "A").End(xlUp).Row 'Choose a column that has data to the end to get the last row number change "A" to the column
Set Startsheet = ActiveSheet
Rows("1:1").Select
If ActiveSheet.AutoFilterMode = False Then
    Selection.AutoFilter
End If
ActiveSheet.Range("$A$1:$I$" & LR).AutoFilter Field:=3, Criteria1:=Array( _
    "2*", "D002") _
    , Operator:=xlFilterValues
Range("A1:I" & LR).SpecialCells(xlCellTypeVisible).Copy
Sheets.Add After:=ActiveSheet
ActiveSheet.Paste
Startsheet.Select
ActiveSheet.Range("$A$1:$I$" & LR).AutoFilter Field:=3, Criteria1:="=D004", _
    Operator:=xlOr, Criteria2:="=D005"
Range("A1:I" & LR).SpecialCells(xlCellTypeVisible).Copy
Sheets.Add After:=ActiveSheet
ActiveSheet.Paste
Set Startsheet = Nothing
End Sub

This works for me however it doesn't filter 2*. I am only left with D002.

 

[Dave_george]

Alternative code if you really want a VBA solution:

Option Explicit
Sub Filter_Copy()
    Dim ws1 As Worksheet, ws2 As Worksheet, ws3 As Worksheet
    Set ws1 = Worksheets("Sheet1")          '<--- *** Change sheet names to suit ***
    Set ws2 = Worksheets("Sheet2")
    Set ws3 = Worksheets("Sheet3")
   
    With ws1
        If .AutoFilterMode Then .AutoFilter.ShowAllData
        With .Range("A1").CurrentRegion
            .AutoFilter 3, "D002", 2, "2*"
            If WorksheetFunction.Subtotal(3, .Columns(1)) > 1 Then
                .Copy ws2.Range("A1")
            End If
            .AutoFilter 3, "D004", 2, "D005"
            If WorksheetFunction.Subtotal(3, .Columns(1)) > 1 Then
                .Copy ws3.Range("A1")
            End If
            .AutoFilter
        End With
    End With
End Sub

This works for me however it doesn't filter 2*. I am only left with D002.

 

[kevin9999]

This works for me however it doesn't filter 2*. I am only left with D002.

It works for me:

Book1
	A	B	C	D	E	F	G	H	I
1	CUSTOMER_ID	Names	HUB	WAVE	CASES	VOLUME	WEIGHT	SEG	SHIPMENT_GROUP
2	1002	n/a	D002	4	584	7.58	3,284.79	STD
3	1003	n/a	D002	4	680	8.14	4,063.38	STD
4	1009	n/a	D002	4	207	2.93	1,332.82	STD
5	2567	n/a	2567	4	78	0.93	422.57	STD
6	2605	n/a	2605	4	370	6.79	2,482.73	STD
7	2640	n/a	2640	4	66	2.04	378.43	STD
8	2641	n/a	2641	4	68	0.5	292.69	STD
9	2663	n/a	2663	4	54	0.52	255.28	STD
10	2695	n/a	2695	4	54	1.27	279.84	STD
11	2719	n/a	2719	4	160	4	903.73	STD
12	2722	n/a	2722	4	748	13.57	6,164.86	STD
13	2737	n/a	2737	4	61	0.45	361.51	STD
Sheet2

Could you share your actual file via Google Drive, Dropbox or similar file sharing platform so we can get to the bottom of the problem?

 

[Dave_george]

Yes. Please see below.
DATA FILE

 

[Dave_george]

Alternative code if you really want a VBA solution:

Option Explicit
Sub Filter_Copy()
    Dim ws1 As Worksheet, ws2 As Worksheet, ws3 As Worksheet
    Set ws1 = Worksheets("Sheet1")          '<--- *** Change sheet names to suit ***
    Set ws2 = Worksheets("Sheet2")
    Set ws3 = Worksheets("Sheet3")
   
    With ws1
        If .AutoFilterMode Then .AutoFilter.ShowAllData
        With .Range("A1").CurrentRegion
            .AutoFilter 3, "D002", 2, "2*"
            If WorksheetFunction.Subtotal(3, .Columns(1)) > 1 Then
                .Copy ws2.Range("A1")
            End If
            .AutoFilter 3, "D004", 2, "D005"
            If WorksheetFunction.Subtotal(3, .Columns(1)) > 1 Then
                .Copy ws3.Range("A1")
            End If
            .AutoFilter
        End With
    End With
End Sub

I Just made changes to D002* and it worked. Thank you.

 

[kevin9999]

Yes. Please see below.
DATA FILE

It says the transfer has 'expired'? Unable to download