Option Explicit
Dim WbColecRgn As Workbook, WbCopyRng As Workbook, WbCriteriaRng As Workbook
'MyWks As Worksheet
Dim MyRngColection As Range
Dim iRow As Integer
Dim tRgColecWbDir As String, tRgColecWb As String, tRgColecWks As String, tRgColec As String
Dim MyCriteriaDir As String, MyCriteriaWb As String, MyCriteriaWk As String, MyCriteriaRng As String
Dim MyCopyToRangeDir As String, MyCopyToRangeWb As String, MyCopyToRangeWk As String, MyCopyToRangeRng As String
Const MyFilterActionCopy As Integer = 2
Dim MyCriteriaRange As Variant, MyCopyToRange As Variant, MyUnique As Variant
Sub SetDataListToAdFilter()
Application.ScreenUpdating = False
iRow = 2
With ThisWorkbook.Worksheets("Sheet1")
tRgColecWbDir = .Cells(iRow, 2)
tRgColecWb = .Cells(iRow, 3)
tRgColecWks = .Cells(iRow, 4)
tRgColec = .Cells(iRow, 5)
If bIsBookOpen(.Cells(iRow, 3)) Then
Set WbColecRgn = Workbooks(tRgColecWb)
'Set MyWks = Worsheets(tRgColecWks)
Else
Set WbColecRgn = Workbooks.Open(tRgColecWbDir & tRgColecWb)
'Set MyWks = Worsheets(tRgColecWks)
End If
Set MyRngColection = WbColecRgn.Worksheets(tRgColecWks).Range(tRgColec)
'MyFilterAction = Cells(2, 14)
End With
Call SetCriteriaAndCopyToRange
MyRngColection.AdvancedFilter MyFilterActionCopy, MyCriteriaRange, MyCopyToRange, MyUnique
Call DeleteFilterName
WbColecRgn.Close True
WbCriteriaRng.Close True
Application.ScreenUpdating = True
End Sub
Sub SetCriteriaAndCopyToRange()
Application.ScreenUpdating = False
With ThisWorkbook.Worksheets("Sheet1")
MyCriteriaDir = .Cells(iRow, 6)
MyCriteriaWb = .Cells(iRow, 7)
MyCriteriaWk = .Cells(iRow, 8)
MyCriteriaRng = .Cells(iRow, 9)
If bIsBookOpen(MyCriteriaWb) Then
Set WbCriteriaRng = Workbooks(MyCriteriaWb)
Else
Set WbCriteriaRng = Workbooks.Open(MyCriteriaDir & MyCriteriaWb)
End If
MyCopyToRangeDir = .Cells(iRow, 10)
MyCopyToRangeWb = .Cells(iRow, 11)
MyCopyToRangeWk = .Cells(iRow, 12)
MyCopyToRangeRng = .Cells(iRow, 13)
If bIsBookOpen(MyCopyToRangeWb) Then
Set WbCopyRng = Workbooks(MyCopyToRangeWb)
Else
Set WbCopyRng = Workbooks.Open(MyCopyToRangeDir & MyCopyToRangeWb)
End If
Set MyCriteriaRange = Workbooks(MyCriteriaWb).Worksheets(MyCriteriaWk).Range(MyCriteriaRng)
Set MyCopyToRange = Workbooks(MyCopyToRangeWb).Worksheets(MyCopyToRangeWk).Range(MyCopyToRangeRng)
MyUnique = .Cells(iRow, 15)
End With
Application.ScreenUpdating = True
End Sub
Sub MyAdvancedFilter(MyFilterAction As String, MyCriteriaRange As Variant, MyCopyToRange As Variant, MyUnique As Variant)
MyCollectionRange.AdvancedFilter MyFilterAction, MyCriteriaRange, MyCopyToRange, MyUnique
End Sub
Sub DeleteFilterName()
On Error Resume Next
With ActiveWorkbook
.Names("_FilterDatabase").Delete
.Names("Criteria").Delete
.Names("Extract").Delete
End With
End Sub
Function bIsBookOpen(ByRef szBookName As String) As Boolean
' Rob Bovey
On Error Resume Next
bIsBookOpen = Not (Application.Workbooks(szBookName) Is Nothing)
End Function
