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

 

[ItalianPlatinum]

Please post the function

Public Function FileSaveAs(argWbk As Workbook, argFileFullName As String) As String

    Dim sFileName   As String
    Dim sFileExt    As String
    Dim sFilters    As String
    Dim iFiltIx     As Integer
    Dim vFormat     As Long

    ' compose string of used formats
    sFilters = "CSV (Comma delimited)(*.csv),*.csv,"
    
    ' get initial file extension
    sFileExt = Right(argFileFullName, Len(argFileFullName) - InStrRev(argFileFullName, "."))
    ' set current filter accordingly
    Select Case LCase(sFileExt)
        Case "csv":     iFiltIx = 3
        Case Else:      iFiltIx = 1
    End Select
    ' user provides final folder and file name
    sFileName = Application.GetSaveAsFilename(InitialFileName:=argFileFullName, _
                                              FileFilter:=sFilters, _
                                              FilterIndex:=iFiltIx)
    If sFileName = "False" Then
        MsgBox "User has canceled.", vbExclamation, "SaveAs"
        FileSaveAs = ""
        GoTo SUB_DONE
    End If
    ' get final file extension
    sFileExt = Right(sFileName, Len(sFileName) - InStrRev(sFileName, "."))
    ' save file as requested
    Select Case LCase(sFileExt)
        Case "csv":     vFormat = xlCSV
        Case Else:      vFormat = xlOpenXMLWorkbook
    End Select
    argWbk.SaveAs Filename:=sFileName, FileFormat:=vFormat
    FileSaveAs = sFileName
SUB_DONE:
End Function

 

[Yongle]

Thanks
Will continue tomorrow

 

[Yongle]

I am removing all doubt - everything is Yes, No or N/A
Please do not offer any explanations - I will ask another series of questions based on the answers you provide

File Name
You requested that the Input Box be replaced with SaveAs box, where the file name is prefilled
(fName = "xxxxx" & Format(Now, "MMDDYY") & ".csv")

User choices
In the SaveAs screen the user may choose to
- save
- enter a different name and save
- navigate to a different folder (and possibly enter a different file name) and save
- cancel

Q1 Is the "xxxxx" in the default name string a constant? (= do the same characters ALWAYS precede the date string?) YES or NO?
Q2 is the user permitted to enter a different file name? YES or NO?
Q3 does that name require verification to conform to your naming convention? YES , NO or N/A?
Q4 is the user permitted to choose a different save to folder? YES or NO?
Q5 is the user permitted to cancel ? Yes or No?

 

[ItalianPlatinum]

I am removing all doubt - everything is Yes, No or N/A
Please do not offer any explanations - I will ask another series of questions based on the answers you provide

File Name
You requested that the Input Box be replaced with SaveAs box, where the file name is prefilled
(fName = "xxxxx" & Format(Now, "MMDDYY") & ".csv")

User choices
In the SaveAs screen the user may choose to
- save
- enter a different name and save
- navigate to a different folder (and possibly enter a different file name) and save
- cancel

Q1 Is the "xxxxx" in the default name string a constant? (= do the same characters ALWAYS precede the date string?) YES or NO?
Q2 is the user permitted to enter a different file name? YES or NO?
Q3 does that name require verification to conform to your naming convention? YES , NO or N/A?
Q4 is the user permitted to choose a different save to folder? YES or NO?
Q5 is the user permitted to cancel ? Yes or No?

Yes
No
Yes
Yes
Yes

 

[Yongle]

What should happen when the user selects cancel?

 

[ItalianPlatinum]

What should happen when the user selects cancel?

it leaves a workbook open with that upload open.

 

[ItalianPlatinum]

it leaves a workbook open with that upload open.

Yongle - I can manage this i can have it save over each time by removing the input box. if you disregard the most recent request only thing is could a status box be present saying "file saved or file not saved" if not saved. ie someone in the upload file so unable to save.

 

[Yongle]

Amend the usual 2 lines
I think this is now as you require
Do you want explanatory notes?

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, sFileName As String, msg 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)
'file name
    fName = "abc" & Format(Now, "MMDDYY") & ".csv"
    sMyFile = fPath & fName
'is that file already open?
    On Error Resume Next
    Windows(fName).Activate:    If Err.Number = 0 Then ActiveWorkbook.Close True
    On Error GoTo 0
'create new workbook and delete workings sheets
    Set oWb = Workbooks.Add
    ws4.UsedRange.Copy oWb.Sheets(1).Cells(1, 1)
    App.DisplayAlerts = False: ws3.Delete: ws4.Delete: App.DisplayAlerts = True
'save csv
    sFileName = Application.GetSaveAsFilename(InitialFileName:=sMyFile, FileFilter:="CSV (Comma delimited)(*.csv),*.csv,", FilterIndex:=3)
    If sFileName = "False" Then
        msg = "cancelled"
    ElseIf Right(sFileName, Len(sFileName) - InStrRev(sFileName, "\")) = fName Then
        oWb.SaveAs Filename:=sFileName, FileFormat:=xlCSV
        oWb.Close False
        msg = "saved" & vbCr & sFileName
    Else: msg = "not saved - file name amended"
    End If
    MsgBox msg
    App.Calculation = xlCalculationAutomatic: App.ScreenUpdating = True
End Sub

 

[ItalianPlatinum]

Amend the usual 2 lines
I think this is now as you require
Do you want explanatory notes?

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, sFileName As String, msg 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)
'file name
    fName = "abc" & Format(Now, "MMDDYY") & ".csv"
    sMyFile = fPath & fName
'is that file already open?
    On Error Resume Next
    Windows(fName).Activate:    If Err.Number = 0 Then ActiveWorkbook.Close True
    On Error GoTo 0
'create new workbook and delete workings sheets
    Set oWb = Workbooks.Add
    ws4.UsedRange.Copy oWb.Sheets(1).Cells(1, 1)
    App.DisplayAlerts = False: ws3.Delete: ws4.Delete: App.DisplayAlerts = True
'save csv
    sFileName = Application.GetSaveAsFilename(InitialFileName:=sMyFile, FileFilter:="CSV (Comma delimited)(*.csv),*.csv,", FilterIndex:=3)
    If sFileName = "False" Then
        msg = "cancelled"
    ElseIf Right(sFileName, Len(sFileName) - InStrRev(sFileName, "\")) = fName Then
        oWb.SaveAs Filename:=sFileName, FileFormat:=xlCSV
        oWb.Close False
        msg = "saved" & vbCr & sFileName
    Else: msg = "not saved - file name amended"
    End If
    MsgBox msg
    App.Calculation = xlCalculationAutomatic: App.ScreenUpdating = True
End Sub

getting this error message

 

[Yongle]

The message is telling you what the error is.

It occurred because you did not use the latest posted macro.
I am guessing you pasted what you think changed in my latest code into your previous macro - that was dangerous

Use what I posted and amend the 2 lines that I marked with "amend" and then all should be fine. ?