Advanced filtering based off of another file Vlookup

[ItalianPlatinum]

Hello - I have posted before but I am not getting any hits. so going to keep my problem brief and generic. Hopefully someone could lead me to an answer or refer me to a way to get there.

Existing Code: Will open another worksheet (CSV) and covert it to a format I need to upload. The data within that file has unique characters in column A. In my worksheet where I execute the code from has those same unique values in Column B but also has them grouped by Column A. And what I am looking to do is list out all of the Column A's I want to see in that upload.

Example below: (i only want my upload to show 10 records)

Book2
	A	B	C	D
1	Type	Unique Tag		For Export
2	AA	ABC1		AA
3	AA	BBB1		CC
4	AA	CCC1		EE
5	AA	DDD1
6	BB	ACD1
7	BB	ADD1
8	BB	AFF1
9	BB	AGG1
10	CC	LLL1
11	CC	LLL2
12	CC	LLL3
13	CC	YYY4
14	DD	UUU8
15	DD	PPP0
16	DD	MNM1
17	EE	AFD1
18	EE	DF21
Sheet2

 

[Yongle]

I will provide notes explaining how everything works after the code is finalised
Code below should do everything required ( I think )

You did not specify how the variable bit of the file name is created ( xxxx in one of your previous posts) so have included an input box - is that what you want?
Code exports result to CSV before deleting the 2 created sheets
User is asked for confirmation if the file name already exists in save to folder - is that what you want?

Replace previous code and amend these 2 lines

    fPath = "Network Path\"          'END path with path separator \
    Set ws1 = Sheets("Execute")     'AMEND

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
    Dim dataRng As Range
    Dim fPath As String, fName As String, sMyFile As String
    Dim oWb As Workbook
    fPath = "Network Path\"          'END with path separator
    Set ws1 = Sheets("Execute")     'AMEND
    Set ws2 = Sheets("correct upload")
    Set dataRng = ws2.Range("A1").CurrentRegion
    Set App = Excel.Application
    App.ScreenUpdating = False: App.Calculation = xlCalculationManual
'create arrays of values
    expArr = ws1.Range("X13", ws1.Range("X" & ws1.Rows.Count).End(xlUp).Offset(1)).Value
    tagArr = ws1.Range("A13", ws1.Range("A" & ws1.Rows.Count).End(xlUp)).Resize(, 5).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, 5)), CStr(tagArr(a, 5))
        Next b
    Next a
    On Error GoTo 0
    c = coll.Count
'create temp sheet
    Set ws3 = ws2.Parent.Worksheets.Add(after:=ws2)
'add criteria
    ws3.Rows(1).Value = ws2.Rows(1).Value
    For a = 1 To c
        ws3.Cells(a + 1, 2) = 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("B1").Resize(c + 1), Unique:=False
'copy visible cells to results sheet
    Set ws4 = Sheets.Add(after:=ws2)
    dataRng.SpecialCells(xlCellTypeVisible).Copy ws4.Cells(1, 1)
'save to csv and tidy up
    fName = InputBox("enter file name")
    sMyFile = fPath & fName & Format(Now, "MMDDYY") & ".csv"
    Set oWb = Workbooks.Add
    ws4.UsedRange.Copy oWb.Sheets(1).Cells(1, 1)
    On Error Resume Next
    oWb.SaveAs Filename:=sMyFile, FileFormat:=xlCSV
    oWb.Close False
    On Error GoTo 0
    App.DisplayAlerts = False
    ws3.Delete
    ws4.Delete
    App.DisplayAlerts = True
    App.Calculation = xlCalculationAutomatic: App.ScreenUpdating = True
End Sub

To run the macro at the end of your original code
insert this as the last line in the code that generates sheet correct upload

    Call AdvFilter

 

[ItalianPlatinum]

I will provide notes explaining how everything works after the code is finalised
Code below should do everything required ( I think )

You did not specify how the variable bit of the file name is created ( xxxx in one of your previous posts) so have included an input box - is that what you want?
Code exports result to CSV before deleting the 2 created sheets
User is asked for confirmation if the file name already exists in save to folder - is that what you want?

Replace previous code and amend these 2 lines

    fPath = "Network Path\"          'END path with path separator \
    Set ws1 = Sheets("Execute")     'AMEND

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
    Dim dataRng As Range
    Dim fPath As String, fName As String, sMyFile As String
    Dim oWb As Workbook
    fPath = "Network Path\"          'END with path separator
    Set ws1 = Sheets("Execute")     'AMEND
    Set ws2 = Sheets("correct upload")
    Set dataRng = ws2.Range("A1").CurrentRegion
    Set App = Excel.Application
    App.ScreenUpdating = False: App.Calculation = xlCalculationManual
'create arrays of values
    expArr = ws1.Range("X13", ws1.Range("X" & ws1.Rows.Count).End(xlUp).Offset(1)).Value
    tagArr = ws1.Range("A13", ws1.Range("A" & ws1.Rows.Count).End(xlUp)).Resize(, 5).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, 5)), CStr(tagArr(a, 5))
        Next b
    Next a
    On Error GoTo 0
    c = coll.Count
'create temp sheet
    Set ws3 = ws2.Parent.Worksheets.Add(after:=ws2)
'add criteria
    ws3.Rows(1).Value = ws2.Rows(1).Value
    For a = 1 To c
        ws3.Cells(a + 1, 2) = 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("B1").Resize(c + 1), Unique:=False
'copy visible cells to results sheet
    Set ws4 = Sheets.Add(after:=ws2)
    dataRng.SpecialCells(xlCellTypeVisible).Copy ws4.Cells(1, 1)
'save to csv and tidy up
    fName = InputBox("enter file name")
    sMyFile = fPath & fName & Format(Now, "MMDDYY") & ".csv"
    Set oWb = Workbooks.Add
    ws4.UsedRange.Copy oWb.Sheets(1).Cells(1, 1)
    On Error Resume Next
    oWb.SaveAs Filename:=sMyFile, FileFormat:=xlCSV
    oWb.Close False
    On Error GoTo 0
    App.DisplayAlerts = False
    ws3.Delete
    ws4.Delete
    App.DisplayAlerts = True
    App.Calculation = xlCalculationAutomatic: App.ScreenUpdating = True
End Sub

To run the macro at the end of your original code
insert this as the last line in the code that generates sheet correct upload

    Call AdvFilter

Alright I catered it to my big data file. it looks friggin awesome. Absolute great job. I do have a few questions for maybe control spots I would like to add and not sure if too much modification needed I would assume no

1) Is there a way to check if the file I save to is already open (maybe create a dialog box saying file is open)? it looks like when it is the code will just run and stop with no errors but won't actually complete obviously because the file is open.
2) being asked to override I am fine with. but if the user selects no could the file stay open as a new workbook then the user can manually save it if they want to?

 

[Yongle]

How about this ...

fName now incorporates the date element and the csv extension (ie = the complete name)
Try to activate a window with complete name (proves that the file is open)
If open : save and close that file
Allow the user to overwrite if he wants

Let me know if you would prefer it to work in a different way
(eg those lines could be inserted at the top of the code before anything else happens, giving the user the opportunity to exit)

Extract - amended last few lines of code

'save to csv and tidy up
    fName = InputBox("enter file name")
    fName = fName & Format(Now, "MMDDYY") & ".csv"
    sMyFile = fPath & fName
On Error Resume Next
    Windows(fName).Activate
    If Err.Number = 0 Then ActiveWorkbook.Close True
    End If
On Error GoTo 0
    Set oWb = Workbooks.Add
    ws4.UsedRange.Copy oWb.Sheets(1).Cells(1, 1)
    On Error Resume Next
    oWb.SaveAs Filename:=sMyFile, FileFormat:=xlCSV
    oWb.Close False
    On Error GoTo 0
    App.DisplayAlerts = False
    ws3.Delete
    ws4.Delete
    App.DisplayAlerts = True
    App.Calculation = xlCalculationAutomatic: App.ScreenUpdating = True

 

[ItalianPlatinum]

How about this ...

fName now incorporates the date element and the csv extension (ie = the complete name)
Try to activate a window with complete name (proves that the file is open)
If open : save and close that file
Allow the user to overwrite if he wants

Let me know if you would prefer it to work in a different way
(eg those lines could be inserted at the top of the code before anything else happens, giving the user the opportunity to exit)

Extract - amended last few lines of code

'save to csv and tidy up
    fName = InputBox("enter file name")
    fName = fName & Format(Now, "MMDDYY") & ".csv"
    sMyFile = fPath & fName
On Error Resume Next
    Windows(fName).Activate
    If Err.Number = 0 Then ActiveWorkbook.Close True
    End If
On Error GoTo 0
    Set oWb = Workbooks.Add
    ws4.UsedRange.Copy oWb.Sheets(1).Cells(1, 1)
    On Error Resume Next
    oWb.SaveAs Filename:=sMyFile, FileFormat:=xlCSV
    oWb.Close False
    On Error GoTo 0
    App.DisplayAlerts = False
    ws3.Delete
    ws4.Delete
    App.DisplayAlerts = True
    App.Calculation = xlCalculationAutomatic: App.ScreenUpdating = True

getting this error

 

[Yongle]

Delete

End If

 

[ItalianPlatinum]

Delete

End If

is there a way to prepopulate the input box? I see the naming I want it to be but if i press ok with it blank it doesnt apply the naming only (date only) if i type it in. wanted to somewhat remove that human element. know what I mean?

 

[Yongle]

It is possible to prevent an empty value by forcing the user to enter value before they move on.
Here the user is locked in the loop until name is a minimum of 5 characters

    Do
         fName = InputBox("enter file name at least 5 characters in length")
    Loop Until Len(fName) > 4

 

[Yongle]

Prepopulate like this

    fName = InputBox("amend file name", , "default name here")

 

[ItalianPlatinum]

Prepopulate like this

    fName = InputBox("amend file name", , "default name here")

Nice, exactly what I was thinking. And if i wanted full visibility in the existing folder via that dialog box like the below? is that capable?

 

[Yongle]

And if i wanted full visibility in the existing folder via that dialog box like the below? is that capable?

Not sure what you want and how you want to use it
Do you want to browse to a folder, browse to a file, look to see which file names already exist in a folder, something else?