Filter database into new sheet, by copying certain columns only, not whole table.
Fastest way I found so far to move filtered data into new sheet.
Tried Advanced Filter, Pivot, and VBA-pure method, all were not as fast as this method.
Accepts up to 3 columns to filter, each with one condition only, maybe in near future we can add more conditions and more columns.
Sub ANmaFilter3(SrcCellA1, ColumnList, Move2Sheet _
, Filter1Col, Filter1Val _
, Optional Filter2Col = 0, Optional Filter2Val = "" _
, Optional Filter3Col = 0, Optional Filter3Val = "" _
, Optional SrcSheet = "Active", Optional SrcWB = "This" _
, Optional Move2WB = "This" _
)
'
' Filters a table showing only few rows.
' Doing what AdvancedFilter does but in a faster way since we are only showing some columns, not all.
'
' SrcCellA1, SrcSheet, SrcWB: Starting cell of big db to filter, sheet name, and workbook name
' ColumnList: List of columns to be moved, [D,G,K,UZ] not all columns will be moved, but we need to bring any column we need to filter by.
' Move2Sheet: Sheet will move data to, [Sheet3] will be cleared, has to be blank.
' Filter1Col, Filter1Val: Column Index to filter by [3], value (or full condition of filter, like >3, < >"Ream", etc. ) [4]
' ...
'
If SrcWB = "This" Then SrcWB = ThisWorkbook.Name
If SrcWB = "Active" Then SrcWB = ActiveWorkbook.Name
If SrcSheet = "Active" Then SrcSheet = Workbooks(SrcWB).ActiveSheet.Name
If Move2WB = "This" Then Move2WB = ThisWorkbook.Name
If Move2WB = "Active" Then Move2WB = ActiveWorkbook.Name
OldScrUpd = Application.ScreenUpdating
OldCalc = Application.Calculation
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
' Style4 = AutoFilter, Filter sheet in place after moving some columns, not all > > Very fast comparing with other solutions
DBRows = Workbooks(SrcWB).Worksheets(SrcSheet).Range("A1").CurrentRegion.Rows.Count
Workbooks(Move2WB).Worksheets(Move2Sheet).AutoFilterMode = False
Workbooks(Move2WB).Worksheets(Move2Sheet).Range("D1").EntireColumn.EntireRow.Clear
X1 = 0
For Each Coo in Split(ListColumns, ",")
DBR1 = "$" & Coo & "$1:$" & Coo & "$" & DBRows
Workbooks(Move2WB).Worksheets(Move2Sheet).Range("D1:D" & DBRows).Offset(0, X1).Value = Workbooks(SrcWB).Worksheets(SrcSheet).Range(DBR1).Value
X1 = X1 + 1
Next
Move2Range = "$D$1:$" & ColumnName("D1", X1) & "$" & DBRows
Workbooks(Move2WB).Worksheets(Move2Sheet).Range(Move2Range).AutoFilter Filter1Col, Filter1Val
If Filter2Col > 0 And Filter2Val > "" Tnen
Workbooks(Move2WB).Worksheets(Move2Sheet).Range(Move2Range).AutoFilter Filter2Col, Filter2Val
End If
If Filter3Col > 0 And Filter3Val > "" Tnen
Workbooks(Move2WB).Worksheets(Move2Sheet).Range(Move2Range).AutoFilter Filter3Col, Filter3Val
End If
Application.ScreenUpdating = OldScrUpd
Application.Calculation = OldCalc
End Sub
, Filter1Col, Filter1Val _
, Optional Filter2Col = 0, Optional Filter2Val = "" _
, Optional Filter3Col = 0, Optional Filter3Val = "" _
, Optional SrcSheet = "Active", Optional SrcWB = "This" _
, Optional Move2WB = "This" _
)
'
' Filters a table showing only few rows.
' Doing what AdvancedFilter does but in a faster way since we are only showing some columns, not all.
'
' SrcCellA1, SrcSheet, SrcWB: Starting cell of big db to filter, sheet name, and workbook name
' ColumnList: List of columns to be moved, [D,G,K,UZ] not all columns will be moved, but we need to bring any column we need to filter by.
' Move2Sheet: Sheet will move data to, [Sheet3] will be cleared, has to be blank.
' Filter1Col, Filter1Val: Column Index to filter by [3], value (or full condition of filter, like >3, < >"Ream", etc. ) [4]
' ...
'
If SrcWB = "This" Then SrcWB = ThisWorkbook.Name
If SrcWB = "Active" Then SrcWB = ActiveWorkbook.Name
If SrcSheet = "Active" Then SrcSheet = Workbooks(SrcWB).ActiveSheet.Name
If Move2WB = "This" Then Move2WB = ThisWorkbook.Name
If Move2WB = "Active" Then Move2WB = ActiveWorkbook.Name
OldScrUpd = Application.ScreenUpdating
OldCalc = Application.Calculation
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
' Style4 = AutoFilter, Filter sheet in place after moving some columns, not all > > Very fast comparing with other solutions
DBRows = Workbooks(SrcWB).Worksheets(SrcSheet).Range("A1").CurrentRegion.Rows.Count
Workbooks(Move2WB).Worksheets(Move2Sheet).AutoFilterMode = False
Workbooks(Move2WB).Worksheets(Move2Sheet).Range("D1").EntireColumn.EntireRow.Clear
X1 = 0
For Each Coo in Split(ListColumns, ",")
DBR1 = "$" & Coo & "$1:$" & Coo & "$" & DBRows
Workbooks(Move2WB).Worksheets(Move2Sheet).Range("D1:D" & DBRows).Offset(0, X1).Value = Workbooks(SrcWB).Worksheets(SrcSheet).Range(DBR1).Value
X1 = X1 + 1
Next
Move2Range = "$D$1:$" & ColumnName("D1", X1) & "$" & DBRows
Workbooks(Move2WB).Worksheets(Move2Sheet).Range(Move2Range).AutoFilter Filter1Col, Filter1Val
If Filter2Col > 0 And Filter2Val > "" Tnen
Workbooks(Move2WB).Worksheets(Move2Sheet).Range(Move2Range).AutoFilter Filter2Col, Filter2Val
End If
If Filter3Col > 0 And Filter3Val > "" Tnen
Workbooks(Move2WB).Worksheets(Move2Sheet).Range(Move2Range).AutoFilter Filter3Col, Filter3Val
End If
Application.ScreenUpdating = OldScrUpd
Application.Calculation = OldCalc
End Sub
SrcCellA1, ColumnList, Move2Sheet , Filter1Col, Filter1Val, Optional Filter2Col = 0, Optional Filter2Val = "", Optional Filter3Col = 0, Optional Filter3Val = "", Optional SrcSheet = "Active", Optional SrcWB = "This", Optional Move2WB = "This"
Views 196
Downloads 56
CodeID
DB ID
ANmarAmdeen
615
Revisions
v1.0
Friday
October
13
2023