VBA to filter result and paste

[hwong8848]

Hi all, I had been using the function "Filter" and "FIND" to get the data I need in some range. However, since it seems to be quite slow (correct me if Im wrong)

I have attached the sheet as example, hope there is a way to filter using VBA and hardcoded them rather than having formulas.

Book1
	A	B	C	D	E	F	G	H	I	J
1	No.	Amount	Type	Year			Type 1	AXA
2	1	488584.8	ING	2017			Type 2	ING
3	2	250632.5	Barclays	1942			Type 3	Barclays
4	3	457570.7	Barclays Inc	2008
5	4	788922.4	AXA	2001			Year 1	1927
6	5	893828.3	Barclays Inc	1927			Year 2	2000
7	6	702071.8	Barclays Inc	1977			Year 3	1885
8	7	235300.4	Barclays	1911
9	8	16744.72	AXA Asia	1917			List of data below
10	9	431784.2	Barclays Inc	2005			No.	Amount	Type	Year
11	10	960657.1	Barclays Inc	1932			5	893828.3	Barclays Inc	1927
12	11	367964.8	AXA Asia	2017			16	231481.3	Barclays	1885
13	12	651444.6	AXA	2011			40	672836.9	ING	2000
14	13	680266.1	AXA Asia	1952			55	517833.8	AXA	2000
15	14	582452.5	AXA Asia	1988			61	135398.3	AXA Asia	2000
16	15	454502	AXA Asia	1905
17	16	231481.3	Barclays	1885
18	17	864936	AXA	1969
19	18	151017.6	AXA Asia	1968
20	19	857505.8	ING	2011
21	20	621567.7	Barclays	1997
22	21	441127.6	AXA Asia	1932
23	22	174814.9	AXA Asia	1944
24	23	224838.3	Barclays Inc	1945
25	24	234594.6	AXA	1877
26	25	893053.4	Barclays	1966
27	26	260026.1	AXA	1891
28	27	866069.4	ING	1880
29	28	398682.9	ING	1888
30	29	538950.4	Barclays Inc	1996
31	30	679969.3	Barclays	1896
32	31	378884	Barclays Inc	1984
33	32	355523.3	Barclays	1876
34	33	171003.2	Barclays Inc	2001
35	34	354718.8	Barclays Inc	1978
36	35	415886.7	Barclays Inc	1942
37	36	619948.1	AXA Asia	2012
38	37	118869.7	Barclays Inc	1891
39	38	120148.5	Barclays	1877
40	39	665417.9	Barclays	1913
41	40	672836.9	ING	2000
42	41	178061.4	Barclays	1956
43	42	981607.7	Barclays Inc	1890
44	43	667142.6	Barclays	1994
45	44	823963.5	Barclays Inc	1870
46	45	67132.63	Barclays Inc	1920
47	46	589131.6	Barclays Inc	2008
48	47	172846.9	ING	1875
49	48	923918	ING	1937
50	49	13007.48	Barclays Inc	1973
51	50	507918.4	Barclays Inc	1925
52	51	789229.9	Barclays Inc	1941
53	52	625808.8	ING	1975
54	53	154092.7	Barclays	1990
55	54	552473.8	AXA	1999
56	55	517833.8	AXA	2000
57	56	611265.8	AXA Asia	1912
58	57	407144.4	Barclays Inc	1926
59	58	544767.8	Barclays Inc	1958
60	59	228377.3	Barclays Inc	1954
61	60	545213.3	Barclays Inc	1994
62	61	135398.3	AXA Asia	2000
63	62	546073.9	AXA	1934
64	63	249206	ING	2018
65	64	928358.4	Barclays Inc	1988
66	65	790988.8	AXA Asia	1918
67	66	931209.6	Barclays Inc	1882
68	67	91423.89	ING	1889
69	68	873575.2	AXA	1898
70	69	202411.3	ING	1959
71	70	748599.5	Barclays	1878
72	71	559973.5	AXA	1993
73	72	820930.2	AXA	1910
74	73	843185.9	Barclays	1929
75	74	723126.2	AXA	1954
76	75	193327	Barclays	2007
77	76	244339.7	ING	1950
78	77	61578.2	ING	1949
79	78	588266	Barclays Inc	1942
80	79	957150.5	ING	1957
81	80	500998.3	Barclays Inc	1970
82	81	109669.8	AXA	1948
83	82	947285.8	Barclays Inc	2013
84	83	777129.9	AXA Asia	1890
85	84	313658.5	Barclays Inc	1890
86	85	418338.4	Barclays	2017
87	86	692562.4	ING	2009
88	87	389527.8	AXA Asia	2004
89	88	77174.76	AXA	1926
90	89	604184.2	AXA Asia	1892
91	90	121492	Barclays	2006
92	91	486313.8	Barclays	1944
93	92	364265.5	AXA Asia	1932
94	93	600225.7	Barclays	1901
95	94	436586.4	Barclays	1939
96	95	307823.2	Barclays Inc	2013
97	96	251716.8	AXA	1944
98	97	668885.3	AXA	1995
99	98	601553.3	AXA Asia	2006
100	99	445976.1	AXA Asia	2007
101	100	981655.3	ING	1961
Data

Cell Formulas
Range	Formula
G11:J15	G11	=FILTER(A2:D101,((D2:D101=H7)+(D2:D101=H6)+(D2:D101=H5))*(ISNUMBER(FIND(H1,C2:C101))+(ISNUMBER(FIND(H2,C2:C101))+(ISNUMBER(FIND(H3,C2:C101))))))
Dynamic array formulas.

The blue bit is the place where I want the data to be at.

 

[kevin9999]

The following assumes that your sheet is exactly as you have provided in your sample, and that there's nothing beyond column J.

Option Explicit
Sub AdvancedFilter()
    Application.ScreenUpdating = False
    Dim ws As Worksheet
    Set ws = Worksheets("Data")
    
    If WorksheetFunction.CountA(ws.Range("H1:H3")) = 0 Then
        MsgBox "No Type selected - exiting sub"
        Exit Sub
    ElseIf WorksheetFunction.CountA(ws.Range("H5:H7")) = 0 Then
        MsgBox "No Year selected - exiting sub"
        Exit Sub
    End If
    
    Dim c As Range
    For Each c In ws.Range("H1:H3,H5:H7")
        If c = "" Then c = "MISSING DATA"
    Next c
    
    Dim rngList As Range, rngCriteria As Range, rngCopyTo As Range
    Set rngList = ws.Range("A1").CurrentRegion
    
    With ws
        .Range("L1").Resize(, 2).Value = Array("Type", "Year")
        .Range("H1:H3").Copy .Range("L2").Resize(9)
        .Range("H5").Copy .Range("M2,M6,M10")
        .Range("H6").Copy .Range("M3,M7,M8")
        .Range("H7").Copy .Range("M4,M5,M9")
    End With
    
    For Each c In ws.Range("L2", Cells(Rows.Count, "L").End(xlUp))
        c = c & "*"
    Next c
    
    Set rngCriteria = ws.Range("L1").CurrentRegion
    Set rngCopyTo = ws.Range("G10:J10")
    rngList.AdvancedFilter xlFilterCopy, rngCriteria, rngCopyTo
    
    rngCriteria.ClearContents
    Application.ScreenUpdating = True
End Sub

 

[mmhill]

I took a different apprach ... treated it like a database. There may be some fancy formulas and built-in functions in newer versions of Exce, but I'm on 2016.

You need to create names ranges for DataAnchor, Year, Type and OutputAnchor ... the "anchor" names mean only the top left cell, not the whole range. Paste the FilterMagic code below into a module and run the macro. There is no need to have all the ranges on the same sheet (Year and Type must be on the same sheet). You can have as many YEAR and TYPE rows as you want, just give the range(s) more rows. You can run it manually or you can put the short bit of code below into the sheet module where your YEARS and TYPES ranges are. This will run FilterMagic any time a value is changed in the YEARS or TYPES ranges.

Wit a little modofication, this can work with Excel tables, any number of fields, and any number of additions to the SQL string.

Code to auto run when Year or Type are changed ... put in come module of worksheet containing Year and Type ranges

Dim booRunChangeEvent As Boolean, booRunning As Boolean
Private Sub Worksheet_Change(ByVal Target As Range)
    If booRunning Then Exit Sub
    If booRunChangeEvent Then booRunning = True: Call FilterMagic
    booRunning = False
End Sub
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    booRunChangeEvent = Not Application.Intersect(ActiveCell, Range(Range(strName_YearRange), Range(strName_TypeRange))) Is Nothing
End Sub

Main Code

Option Explicit

Public Const strName_YearRange$ = "\Year"             ' 1 column w Years
Public Const strName_TypeRange$ = "\Type"             ' 1 column w Types
Public Const strName_DataAnchor$ = "\Data"           ' just the top left cell; including headers of where lookup data is
Public Const strName_OutputAnchor$ = "\OutputAnchor" ' just the top left cell; not including headers

Public Sub FilterMagic()
Dim oWb As Workbook, strTmpName$
Dim dbConn As Object, strConn$  'http://www.connectionstrings.com
Dim strSQL$, c As Range, strYr$, strType$, dbRs As Object
    
    Set oWb = ThisWorkbook
    With oWb
        strTmpName = "SafeToDelete_" & Fix(Now() * 10 ^ 8) 'temp name
        .Names.Add strTmpName, Range(strName_DataAnchor).CurrentRegion, True
    End With

    'Make this workbook a database
    Set dbConn = CreateObject("ADODB.Connection"): Set dbRs = CreateObject("ADODB.Recordset")
    strConn = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source='" & oWb.FullName & "';Extended Properties='Excel 12.0 Macro;HDR=YES;IMEX=0';"
    dbConn.Open strConn

    'Base SQL string
    strSQL = "SELECT * FROM " & strTmpName & ";"

    'WHERE YEAR clause
    For Each c In Range(strName_YearRange)
        If c <> Empty And IsNumeric(c) Then strYr = strYr & c & ","
    Next c
    If Len(strYr) > 0 Then strYr = " WHERE YEAR IN (" & Left(strYr, Len(strYr) - 1) & ")"
    strSQL = Replace(strSQL, ";", strYr & ";")

'   'TYPE LIKE clause
    For Each c In Range(strName_TypeRange)
        If c <> Empty Then strType = strType & " or TYPE like '" & c & "%'"
    Next c
    If Len(strType) > 0 Then strType = Right(strType, Len(strType) - 4)
    If Len(strType) > 0 Then If Len(strYr) > 0 Then strType = " AND (" & strType & ")" Else strType = " WHERE (" & strType & ")"
    strSQL = Replace(strSQL, ";", strType & ";")

    'open record set
    dbRs.Open strSQL, strConn
    oWb.Names(strTmpName).Delete
    
    'clear old data and push recordset to worksheet
    With Range(strName_OutputAnchor)
        If .CurrentRegion.Row < .Row Then .CurrentRegion.Offset(1, 0).ClearContents Else .CurrentRegion.ClearContents
        .CopyFromRecordset dbRs
    End With
    
CleanUp:

    dbRs.Close: Set dbRs = Nothing
    dbConn.Close: Set dbConn = Nothing
    Set c = Nothing
    Set oWb = Nothing
    
Exit Sub
    'OTHER SQL CONSTRUCTIONS
    'https://www.devhut.net/advanced-sql-to-connect-with-excel-workbooks/
    'strSQL = "SELECT * FROM DataTable where YEAR in (1927, 2000, 1885)" ''Named range
    'strSQL = "SELECT * FROM [Filter$A1:A100]" 'Range
    'strSQL = "SELECT * FROM [Sheet1$]" ''All the data in a sheet
    'strSQL = "SELECT * FROM [Excel 12.0 XML;HDR=YES;IMEX=1;database=C:\Docs\LTD.xlsx].[SHEETNAME$XX:XX]" ''Refer to second workbook
End Sub