VBA to Filter Data and copy to existing Tab

[Trebor200]

Hi All,

Looking for a better way to filter data and copy to an existing tab and clear existing data beforehand.

I am currently doing this by recording VBA , filtering, selecting tab, pasting etc feel there may be a better / quicker way of running this.

Below is the code i have repeating each time for each known product, all the tabs are created and wish to cycle through the All Data Sheet and copy data to tabs.


Data Example below. number of parts and tabs will grow over time and not limited to what is currently in the list.

    ActiveSheet.ListObjects("Table1").Range.AutoFilter Field:=1, Criteria1:= _
        "ABC123"

    Sheets("ABC123").Select
    Rows("3:3").Select
    Range(Selection, Selection.End(xlDown)).Select
    Application.CutCopyMode = False
    Selection.Delete Shift:=xlUp

    Sheets("All Data").Select
    Range("A9:I10").Select
    Range(Selection, Selection.End(xlDown)).Select
    Selection.Copy
    ActiveWindow.SmallScroll Down:=-10
    Sheets("ABC123").Select
    Range("A2").Select
    ActiveSheet.Paste
    Sheets("All Data").Select
    ActiveSheet.ListObjects("Table1").Range.AutoFilter Field:=1

MrExcel Help.xlsx
	A	B	C	D	E	F	G	H	I
1	Product	Account	Product Trace	Number	Status	Required	# Days	Esca	Delivery
2	DEF456	166672549	0028754293		640	22/06/2021	461		19/02/2021
3	DEF456	166677773	0028765685		640	26/07/2021	437		23/02/2021
4	GHI789	167153941	0029834077		1150	17/10/2022	128		18/06/2021
5	ABC123	167572621	0030747305		1980	11/11/2022	109		08/11/2021
6	ABC123	167572622	0030747316		1640	26/01/2023	64		08/11/2021
7	ABC123	167572623	0030747327		1610	21/02/2023	46		08/11/2021
8	ABC123	167601465	0030810040		1720	13/01/2023	73		16/11/2021
9	ABC123	167601466	0030810048		1610	21/02/2023	46		16/11/2021
10	ABC123	167655654	0030943727		1780	05/01/2023	79		02/12/2021
11	ABC123	167655655	0030943728		1780	11/04/2023	13		02/12/2021
12	ABC123	168135923	0032055746		1780	09/01/2023	77		02/05/2022
13	ABC123	168135924	0032055753		1645	02/03/2023	39		02/05/2022
14	ABC123	168174752	0032138080		1720	06/02/2023	57		26/05/2022
15	ABC123	168435740	0032712322		1640	26/01/2023	64		02/08/2022
16	ABC123	168435753	0032712443		1610	21/02/2023	46		08/08/2022
17	ABC123	168435754	0032712448		1610	21/02/2023	46		05/08/2022
18	ABC123	168435756	0032712455		1610	21/02/2023	46		08/08/2022
19	ABC123	168435757	0032712463		1640	11/04/2023	13		09/08/2022
20	ABC123	168435759	0032712481		1780	11/04/2023	13		08/08/2022
21	ABC123	168550379	0032984078		1720	27/04/2023	1		12/09/2022
22	ABC123	168652164	0033214774		1680	28/04/2023			06/10/2022
23	ABC123	168652166	0033214780		1647	06/03/2023	37		07/10/2022
24	ABC123	168684737	0033288894		1610	21/02/2023	46		14/10/2022
25	ABC123	168743629	0033421439		420	31/05/2022	226		02/11/2022
26	ABC123	168768577	0033482329		420	04/07/2022	202		08/11/2022
27	ABC123	168790302	0033528610		420	12/07/2022	196		15/11/2022
28	ABC123	168893646	0033761930		420	01/08/2022	182		14/12/2022
29	ABC123	168960006	0033912613		420	28/07/2022	184		13/01/2023
30	GHI789	168970867	0033935044		180	05/10/2022	136		13/12/2022
31	GHI789	168970872	0033935093		180	05/10/2022	136		09/12/2022
32	DEF456	169034645	0034091138		140	21/09/2022	146		31/01/2023
33	DEF456	169103566	0034235266		130	29/09/2022	140		22/02/2023
34	123ABC	169345236	0034763320		314	17/04/2023	9		13/12/2022
35	123ABC	169345238	0034763332		400	27/02/2023	42		13/12/2022
36	123ABC	169345239	0034763337		390	15/03/2023	30		13/12/2022
37	DEF456	169402021	0034887622		140	24/02/2023	43		12/04/2023
38	ABC123	169669822	0035505513		420	16/02/2023	49		12/07/2023
39	ABC123	169669823	0035505517		410	13/02/2023	52		13/07/2023
40	ABC123	169669824	0035505519		420	07/02/2023	56		30/06/2023
41	ABC123	169669826	0035505524		420	14/02/2023	51		12/07/2023
42	ABC123	169669827	0035505528		420	29/03/2023	20		30/06/2023
43	GHI789	169751649	0035672179		220	03/04/2023	17		04/03/2024
44	GHI789	169868564	0035931487		135	30/03/2023	19		20/03/2024
All Data

 

[Mario_R]

Hello.
Assuming it is NOT a coincidence that the data you filter on column A and the name of the sheet receiving the copy are the same, then you can use the following:

Sub Macro_8()
  Application.ScreenUpdating = False
  copy_Routine Range("Table1").ListObject, "ABC123"
End Sub

Private Sub copy_Routine(tbl As ListObject, iName$)
Dim ws As Worksheet
If Evaluate("IsRef('" & iName & "'!A1)") Then Set ws = Worksheets(CStr(iName)) Else Set ws = Worksheets.Add(, ActiveSheet)
With ws
  .Name = iName: .Cells(1).CurrentRegion.Delete xlShiftUp
  .Range("A2") = "=" & tbl.Range(2, 1).Address(0, 0, , True) & " = """ & iName & """"
  tbl.Range.AdvancedFilter 2, .Range("A1:A2"), .Range("A3"), False
  .Rows("1:2").Delete: .Cells(1).CurrentRegion.Font.ColorIndex = xlAutomatic
  .Cells(1).CurrentRegion.EntireColumn.AutoFit
End With
End Sub

 

[Jeffrey Mahoney]

Please try this

I created a table per below with a formula. This creates a new sheet if the sheet name for the product doesn't exist. The macro filters, then copies the data to each sheet

Sub UpdateProductCodeSheets()
  Dim TWB As Workbook
  Dim Rng As Range
  Dim OutRng As Range
  Dim Cel As Range
  Dim CC As Range
  Dim ASht As Worksheet
  Dim Sht As Worksheet
  Dim LO As ListObject
  Dim UPL As Range
  Dim SetupSht As Worksheet
  Dim Prod As String
  Dim ProdSht As Worksheet
  Dim Hdrs As Range
  
  
  Set TWB = ThisWorkbook
  Set ASht = TWB.Worksheets("All Data")
  Set Hdrs = ASht.Range("Table1[#Headers]")
  Set LO = ASht.ListObjects("Table1")
  Set SetupSht = TWB.Sheets("Setup")
  Set UPL = SetupSht.Range("UniqueProducts_List")
  
  For Each Cel In UPL
    Prod = Cel.Value
    LO.Range.AutoFilter Field:=1, Criteria1:=Prod  'Filter
    Set Rng = ASht.Range("Table1").SpecialCells(xlCellTypeVisible)                 'Table range
    Set Sht = Nothing
    On Error Resume Next
    Set Sht = TWB.Sheets(Prod)
    On Error GoTo 0
    If Not Sht Is Nothing Then
      Set ProdSht = Sht
    Else
      Sheets.Add After:=ASht
      Set ProdSht = ActiveSheet
      ProdSht.Name = Prod
      Hdrs.Copy ProdSht.Range("A2")
    End If
    
    Set CC = ProdSht.Range("3:3")
    Set OutRng = ProdSht.Range(CC, CC.End(xlDown))
    OutRng.Value = ""
    Set CC = ProdSht.Range("A3")
    Rng.Copy CC
    'Set OutRng = ProdSht.Range(CC, CC.Offset(Rng.Rows.Count - 1, Rng.Columns.Count - 1))
    'OutRng.Value = Rng.Value
    
  Next Cel
  
  
  
End Sub

Book1 20230502.xlsm
	C
1	Unique Products
2	DEF456
3	GHI789
4	ABC123
5	123ABC
Setup

Cell Formulas
Range	Formula
C2:C5	C2	=UNIQUE(Table1[Product])
Dynamic array formulas.

 

[kevin9999]

Another option. Try it on a copy of your data.

Option Explicit
Sub Trebor200()
    Dim ws1 As Worksheet, ws2 As Worksheet
    Set ws1 = Worksheets("All Data")
    Dim d As Object, arrIn, arrOut, i As Long, shtName As String
    Set d = CreateObject("scripting.dictionary")
    arrIn = ws1.Range("A2", ws1.Cells(Rows.Count, "A").End(xlUp))
    
    For i = 1 To UBound(arrIn, 1)
        d(arrIn(i, 1)) = 1
    Next i
    ReDim arrOut(1 To d.Count, 1 To 1)
    arrOut = d.keys
        
    Dim rCrit As Range, rCopyTo As Range
    For i = LBound(arrOut) To UBound(arrOut)
        shtName = arrOut(i)
        If WorksheetExists(shtName) Then
            Set ws2 = Worksheets(shtName)
            ws2.UsedRange.ClearContents
        Else
            ThisWorkbook.Sheets.Add(After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)).Name = shtName
            Set ws2 = Worksheets(shtName)
        End If
        
        Set rCopyTo = ws2.Range("A1").Resize(, 9)
        With ws1.Range("A1").CurrentRegion
            Set rCrit = .Offset(, .Columns.Count + 1).Resize(2, 1)
            rCrit.Cells(1, 1).Value2 = "Product"
            rCrit.Cells(2, 1).Value2 = shtName
            .AdvancedFilter xlFilterCopy, rCrit, rCopyTo
        End With
        rCrit.Cells(1).Resize(2, 1).ClearContents
    Next i
End Sub
Function WorksheetExists(shtName As String, Optional wb As Workbook) As Boolean
    Dim sht As Worksheet
    If wb Is Nothing Then Set wb = ThisWorkbook
    On Error Resume Next
    Set sht = wb.Sheets(shtName)
    On Error GoTo 0
    WorksheetExists = Not sht Is Nothing
End Function

 

[Trebor200]

Thanks All, appreciate the feedback, tried a couple and Kevin9999 solution to work... Thanks again.

 

[kevin9999]

Thanks All, appreciate the feedback, tried a couple and Kevin9999 solution to work... Thanks again.

Glad we could help, and thanks for the feedback