Let's get it working within the one workbook first (before exporting Results sheet to another workbook - that's the easy bit!)
- I have tried to take account of everything you have told me
A. Latest code assumes that there is a sheet looking exactly like the one I named
Execute (with columns A,B & D)
- if that is not the case then go no further, and revert back to me with some further details
B. Replacement code is below. I do not know the correct name for sheet containing columns A,B & D - amend this line in the code
Rich (BB code):
Set ws1 = Sheets("Execute")
C. The macro will
stop after writing the data range to the immediate window using Debug.Print
Display that window with {CTRL} g when in VBA editor
Check the data range address against the actual data in sheet
correct upload
D. If the range address is correct ...
... remove these 2 lines and run the code again
VBA Code:
Debug.Print "Is this the correct data range?", dataRng.Address(0, 0)
End
E. Both temporary and results sheets should appear
(they are now named to make life easier)
F. Let me know if there are any problems before you try amending the code at this stage
G. What is the correct name for sheet ws1?
- I need to amend my version too!
Replacement procedure
VBA Code:
Sub AdvFilter()
Dim ws1 As Worksheet, ws2 As Worksheet, ws3 As Worksheet, ws4 As Worksheet
Dim expArr As Variant, tagArr As Variant
Dim coll As New Collection, App As Application
Dim a As Long, b As Long, c As Long, lastR As Long, lastC As Long
Dim dataRng As Range
Const z As Long = 12 'rows to ignore
Set ws1 = Sheets("Execute") 'MUST AMEND SHEET NAME
Set ws2 = Sheets("correct upload")
lastR = ws2.Cells(ws2.Rows.Count, 1).End(xlUp).Row - z
lastC = ws2.Cells(13, ws2.Columns.Count).End(xlToLeft).Column
Set dataRng = ws2.Cells.Resize(lastR, lastC).Offset(z)
Debug.Print "Is this the correct data range?", dataRng.Address(0, 0) 'delete if first test successful
End 'delete if first test successful
Set App = Excel.Application
App.ScreenUpdating = False: App.Calculation = xlCalculationManual
'create arrays of values
expArr = ws1.Range("D2", ws1.Range("D" & ws1.Rows.Count).End(xlUp).Offset(2)).Value
tagArr = ws1.Range("A2", ws1.Range("A" & ws1.Rows.Count).End(xlUp)).Resize(, 2).Value
'create filter list
On Error Resume Next
For a = 1 To UBound(tagArr)
For b = 1 To UBound(expArr)
If tagArr(a, 1) = expArr(b, 1) Then coll.Add CStr(tagArr(a, 2)), CStr(tagArr(a, 2))
Next b
Next a
On Error GoTo 0
c = coll.Count
'create temp sheet
Set ws3 = ws2.Parent.Worksheets.Add(after:=ws2)
ws3.Name = "temp" & Format(Now, "_mmdd_hh.mm")
'add criteria
ws3.Cells(1, 1) = ws2.Cells(z + 1, 1)
For a = 1 To c
ws3.Cells(a + 1, 1) = coll(a)
Next a
'add data and filter
dataRng.Copy ws3.Cells(c + 3, 1)
Set dataRng = ws3.Cells(c + 3, 1).CurrentRegion
dataRng.AdvancedFilter Action:=xlFilterInPlace, CriteriaRange:=ws3.Range("A1").Resize(c + 1), Unique:=False
'copy visible cells to results sheet
Set ws4 = Sheets.Add(after:=ws2)
ws4.Name = "Result" & Format(Now, "_mmdd_hh.mm")
dataRng.SpecialCells(xlCellTypeVisible).Copy ws4.Cells(1, 1)
App.DisplayAlerts = False
'ws3.Delete '(DO NOT REMOVE THE LEADING APOSTROPHE UNTIL WE KNOW ALL IS WELL!)
App.DisplayAlerts = True
App.Calculation = xlCalculationAutomatic: App.ScreenUpdating = True
End Sub
