Get unique values from a column of a range and filter the range by those unique values one by one and save the filtered results as pdfs and send mail with those pdfs as attachments using VBA updated

 Function RemoveDupesColl(MyArray As Variant) As Variant
'DESCRIPTION: Removes duplicates from your array using the collection method.
'NOTES: (1) This function returns unique elements in your array, but
' it converts your array elements to strings.

'-----------------------------------------------------------------------
    Dim i As Long
    Dim arrColl As New Collection
    Dim arrDummy() As Variant
    Dim arrDummy1() As Variant
    Dim item As Variant
    ReDim arrDummy1(LBound(MyArray) To UBound(MyArray))

    For i = LBound(MyArray) To UBound(MyArray) 'convert to string
        arrDummy1(i) = CStr(MyArray(i))
    Next i
    On Error Resume Next
    For Each item In arrDummy1
       arrColl.Add item, item
    Next item
    Err.Clear
    ReDim arrDummy(LBound(MyArray) To arrColl.Count + LBound(MyArray) - 1)
    i = LBound(MyArray)
    For Each item In arrColl
       arrDummy(i) = item
       i = i + 1
    Next item
    RemoveDupesColl = arrDummy
End Function


Sub filterandpasteandmaildata()


Sheets("Sheet1").Select
If ActiveSheet.AutoFilterMode Or ActiveSheet.FilterMode Then
    On Error Resume Next
    ActiveSheet.ShowAllData
End If


Dim uniquedata()



'MsgBox (samplerange.Rows.Count)
ReDim Preserve uniquedata(ActiveSheet.Range("A2", ActiveSheet.Range("A2").End(xlDown)).Rows.Count)
'MsgBox (UBound(uniquedata))
Dim dict As Object
Dim length As Long
length = 0
Range("B2").Select
While ActiveCell.Value <> ""

uniquedata(length) = ActiveCell.Value
length = length + 1
ActiveCell.Offset(1, 0).Select
Wend

'For length = LBound(uniquedata) To UBound(uniquedata) - 1
'MsgBox (uniquedata(length))
'Next length
Dim uniquedatafinal()
uniquedatafinal = RemoveDupesColl(uniquedata)
'For length = LBound(uniquedatafinal) To UBound(uniquedatafinal) - 1
'MsgBox (uniquedatafinal(length))
'Next length


'now we found the unique names ,let us first delete anysheet containing such unique names and create sheets containing those names
Dim tempsheetname As String
 With Application
        .ScreenUpdating = False
        .DisplayAlerts = False
        .EnableEvents = False
    End With
   
  For length = LBound(uniquedatafinal) To UBound(uniquedatafinal) - 1
tempsheetname = (uniquedatafinal(length))

For Each wks In Application.Worksheets
        If wks.name = tempsheetname Then wks.Delete
    Next

Next length

 For length = LBound(uniquedatafinal) To UBound(uniquedatafinal) - 1
     cntsheets = Application.Sheets.Count
    Set NewSheet = Application.Worksheets.Add(After:=Worksheets(cntsheets))
    NewSheet.name = uniquedatafinal(length)
    Next length
   
    With Application
        .ScreenUpdating = True
        .DisplayAlerts = True
        .EnableEvents = True
    End With

'Now creating sheets is done ,let us go back the data sheet and remove any filter from the sheet
'creating the directory for pdf files

Dim output_file As String, ws_count, i As Integer
Dim path, folder As String
path = "C:\Users\allso\Desktop\excel_to_pdf_2"
folder = dir(path, vbDirectory)
If folder = vbNullString Then

       
                VBA.FileSystem.MkDir (path)
          

    Else

    

    End If
    
Sheets("Sheet1").Select



Dim dataforfilter As String
Dim strtime As String
'set current default printer
Set mynetwork = CreateObject("WScript.network")
mynetwork.setdefaultprinter "Adobe PDF"
Dim objAccess As Object
Set objAccess = CreateObject("Access.Application")
Dim prtLoop As Object
'get current default printer
Set prtLoop = objAccess.Printer
'now we can access the printquality supported by the default printer by using prtloop.printquality
For length = LBound(uniquedatafinal) To UBound(uniquedatafinal) - 1
dataforfilter = Replace(ActiveSheet.Range("A1").CurrentRegion.Address, "$", "")
'MsgBox (dataforfilter)
ActiveSheet.Range(dataforfilter).AutoFilter Field:=2, Criteria1:=uniquedatafinal(length), Operator:=xlFilterValues
'ActiveSheet.Range(dataforfilter).AutoFilter Field:=4, Criteria1:="=Yes", Operator:=xlFilterValues
'sort the filtered range by the column gross sales
dataforfilter = Replace(ActiveSheet.Range("A1").CurrentRegion.Address, "$", "")
'MsgBox (dataforfilter)
Range(dataforfilter).Sort key1:=[h2], Order1:=xlDescending, Header:=xlYes
ActiveSheet.Range("A1").CurrentRegion.Select
Selection.Copy

Sheets(uniquedatafinal(length)).Select
'Range("A1").PasteSpecial xlPasteValues

Range("A1").PasteSpecial xlPasteAllUsingSourceTheme, Operation:=xlNone _
        , SkipBlanks:=False, Transpose:=False
        
'autofitting the columns
ActiveSheet.Cells.Columns.AutoFit
'removing the borders
'changing the font
 With ActiveSheet.Cells.Font
 
        .name = "Georgia Pro"
        .Size = 11
        .Strikethrough = False
        .Superscript = False
        .Subscript = False
        .OutlineFont = False
        .Shadow = False
        .Underline = xlUnderlineStyleNone
        .TintAndShade = 0
        .ThemeFont = xlThemeFontNone
    End With

ActiveSheet.Cells.Borders.LineStyle = xlLineStyleNone

'now saving the sheet as pdf


If Format(CDate(Now), "am/pm") = "am" Then
strtime = Format(Now(), "yyyymmdd\_hhmmss") & " AM"
Else
strtime = Format(Now(), "yyyymmdd\_hhmmss") & " PM"
End If

output_file = path & "\" & Left(ThisWorkbook.name, Len(ThisWorkbook.name) - 5) & "." & ActiveSheet.name & "." & strtime & ".pdf"

'setting the page setup

'ActiveSheet.PageSetup.CenterHeader = "&B&14" & "Financial Data for " & uniquedatafinal(length) & ""

'&""Courier New""

'determine it is am or pm

If Format(CDate(Now), "am/pm") = "am" Then


ActiveSheet.PageSetup.CenterHeader = "&B&14&""Arial Narrow""&K00B0F0" & "Financial Data for " & uniquedatafinal(length) & " on " & "&D" & "," & "&T" & " AM"
Else
ActiveSheet.PageSetup.CenterHeader = "&B&14&""Arial Narrow""&K00B0F0" & "Financial Data for " & uniquedatafinal(length) & " on " & "&D" & "," & "&T" & " PM"

End If

'this is for setting the right footer of print which will print as Page (number of current page) of Total Pages
ActiveSheet.PageSetup.RightFooter = "&B&10&""Arial Narrow""&K00B0F0" & "Page &P of &N"

'change activeprinter to a choice of mine


'this commented out section works best with portrait printing

With ActiveSheet.PageSetup
.CenterHorizontally = True
'.CenterVertically = True
.BottomMargin = 50
.TopMargin = 50
.RightMargin = 10
.LeftMargin = 10
.Zoom = 50
.FitToPagesWide = 1
.FitToPagesTall = False
.PrintTitleRows = ActiveSheet.Rows(1).Address
.Orientation = xlPortrait
.PrintQuality = prtLoop.PrintQuality


End With
'ActiveSheet.PrintPreview
'this section works best for landscape printing
'With ersheet.PageSetup
''for setting portrait or landscape
'.Orientation = xlLandscape
''these next two line will fit all columns in one page
'.FitToPagesWide = 1
'.FitToPagesTall = 1
''this line is responsible for continuing one fixed row on several print pages ,it is similar as excel freeze pane
'.PrintTitleRows = ersheet.Rows(1).Address
'End With
ActiveWorkbook.ActiveSheet.ExportAsFixedFormat xlTypePDF, output_file, xlQualityStandard, openafterpublish:=False
    
    
Sheets("Sheet1").Select
If ActiveSheet.AutoFilterMode Or ActiveSheet.FilterMode Then
    On Error Resume Next
    ActiveSheet.ShowAllData
End If

Next length

If ActiveSheet.AutoFilterMode Then

     ActiveSheet.AutoFilterMode = False

End If


'sending mail with pdf attachments



Dim olapp As Outlook.Application
Dim olemail As Outlook.MailItem
'Dim objFSO As Object
'    Dim objFldr As Object
'    Dim objFile  As Object
'Dim strfullpath As String
'Set objFSO = CreateObject("Scripting.FileSystemObject")
'    Set objFldr = objFSO.GetFolder(Environ("UserProfile") & "\Desktop\excel_to_pdf_2")

Set olapp = New Outlook.Application
Set olemail = olapp.CreateItem(olMailItem)

With olemail

.BodyFormat = olFormatHTML

.Display
.HTMLBody = "Dear Someone" & "<br>" & .HTMLBody
'.Attachments.Add Environ("UserProfile") & "\Desktop\excel_to_pdf_2\Financial Sample.Canada.20200920_022807.pdf"
'For Each objFile In objFldr.Files
'        strfullpath = objFldr.path & "\" & objFile.Name
'
'        If LCase(Trim(objFSO.GetExtensionName(strfullpath))) = "pdf" Then
'        'MsgBox strfullpath
'            'SendasAttachment (strfullpath)
'          .Attachments.Add strfullpath
'        End If
'    Next
For length = LBound(uniquedatafinal) To UBound(uniquedatafinal) - 1
'Dim tmpfile As String
'tmpfile = getlatestfile(uniquedatafinal(length))
.Attachments.Add getlatestfile(uniquedatafinal(length))


.Attachments.Add tmpfile
'MsgBox (uniquedatafinal(length))


Next length

.To = "allsourav2@gmail.com"
.Subject = "Test using VBA"
.Send




End With
Set olapp = Nothing
Set olemail = Nothing
Set objFldr = Nothing
Set objFSO = Nothing
Set mynetwork = Nothing
Set objAccess = Nothing
Set prtLoop = Nothing
End Sub

' ----------------------------------------------------------------
' Purpose: Add Microsoft Outlook Object Library, call a procedure using that library, then remove Outlook Object Library
' ----------------------------------------------------------------
Sub callingProcedureMSOutlookObjLibrary()

    Dim strGUID As String

    'Microsoft Outlook GUID
    strGUID = "{00062FFF-0000-0000-C000-000000000046}"

    'Check if reference is already added to the project, if not add it
    If F_isReferenceAdded(strGUID) = False Then
        ThisWorkbook.VBProject.REFERENCES.AddFromGuid strGUID, 0, 0
    End If
    
    'Calling the procedure using Outlook object library
    Call procedureUsingMSOutlookObjectLibrary
    
    'Check if reference is added to the project, if yes remove
    If F_isReferenceAdded(strGUID) = True Then
        ThisWorkbook.VBProject.REFERENCES.Remove F_idReferenceByGUID(strGUID)
    End If
    
End Sub
' ----------------------------------------------------------------
' Purpose: Create new Outlook document with early binding, add two paragraphs, align the 2nd one to center
' ----------------------------------------------------------------

'sending mail with pdf attachments


Sub procedureUsingMSOutlookObjectLibrary()
Call filterandpasteandmaildata


End Sub

' ----------------------------------------------------------------
' Purpose: Check if an Object Library refernce is added to a VBAProject or not
' ----------------------------------------------------------------
Function F_isReferenceAdded(referenceGUID As String) As Boolean

    Dim varRef As Variant

    'Loop through VBProject references if input GUID found return TRUE otherwise FALSE
    For Each varRef In ThisWorkbook.VBProject.REFERENCES
        
        If varRef.GUID = referenceGUID Then
            F_isReferenceAdded = True
            Exit For
        End If
        
    Next varRef

End Function
' ----------------------------------------------------------------
' Purpose: Return Object Library reference as object, found by its GUID
' ----------------------------------------------------------------
Function F_idReferenceByGUID(referenceGUID As String) As Object

    Dim varRef As Object

    For Each varRef In ThisWorkbook.VBProject.REFERENCES
        
        If varRef.GUID = referenceGUID Then
            Set F_idReferenceByGUID = varRef
            Exit For
        End If
        
    Next varRef

End Function


Function getlatestfile(ByVal city As String)
'MsgBox (city)


Dim lowestval As Long
lowestval = 0
Dim counter As Integer
counter = 1
'MsgBox (counter)
Dim objFSO As Object
Dim objFldr As Object
Dim objFile  As Object
Dim strfullpath As String
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objFldr = objFSO.GetFolder(Environ("UserProfile") & "\Desktop\excel_to_pdf_2")




'.Attachments.Add Environ("UserProfile") & "\Desktop\excel_to_pdf_2\Financial Sample.Canada.20200920_022807.pdf"
For Each objFile In objFldr.Files
        strfullpath = objFldr.path & "\" & objFile.name

        If LCase(Trim(objFSO.GetExtensionName(strfullpath))) = "pdf" Then
        'MsgBox strfullpath
            'SendasAttachment (strfullpath)
            If InStr(1, objFile.name, city) <> 0 Then
            
            'MsgBox (strfullpath)
            Dim key As Long, val As String
            
            If counter = 1 Then
            val = strfullpath
            lowestval = timelapsefromnow(objFile.name, city)
            Else
            If lowestval > timelapsefromnow(objFile.name, city) Then
            
            val = strfullpath
            End If
            End If
            
            
              counter = counter + 1
            
            End If
            
            
          
            
        
        End If
        
        
    Next


'
'For Each key1 In dict.Keys
'   MsgBox (dict(key1))
'
'
'Next key1

'MsgBox (dict.Items(0))

'getlatestfile = dict(dict.Keys()(0))
getlatestfile = val


Set objFSO = Nothing
Set objFldr = Nothing
Set objFSO = Nothing



End Function

Function timelapsefromnow(str As String, searchitem As String)


'str = "Financial Sample.Canada.20201003_233001 PM"
'MsgBox (InStr(1, str, "Canada"))
Dim i As Integer, s As String
str = Replace(str, ".pdf", "")

s = Mid(str, InStr(1, str, searchitem) + Len(searchitem & "."), (Len(str) - InStr(1, str, searchitem)) + 1)


's1 = Mid(s, 1, InStr(1, s, "_") - 1)

's1 = Left(s1, 4) + "/" + Mid(s1, 5, 2) + "/" + Right(s1, Len(s1) - 6)
's1 = Left(Mid(s, 1, InStr(1, s, "_") - 1), 4) + "/" + Mid(Mid(s, 1, InStr(1, s, "_") - 1), 5, 2) + "/" + Right(Mid(s, 1, InStr(1, s, "_") - 1), Len(Mid(s, 1, InStr(1, s, "_") - 1)) - 6)
's2 = Mid(s, InStr(1, s, "_") + 1, Len(s))
's2 = " " & Left(Mid(s, InStr(1, s, "_") + 1, Len(s)), 2) + ":" + Mid(Mid(s, InStr(1, s, "_") + 1, Len(s)), 3, 2) + ":" + Right(Mid(s, InStr(1, s, "_") + 1, Len(s)), Len(Mid(s, InStr(1, s, "_") + 1, Len(s))) - 4)
s = Left(Mid(s, 1, InStr(1, s, "_") - 1), 4) + "/" + Mid(Mid(s, 1, InStr(1, s, "_") - 1), 5, 2) + "/" + Right(Mid(s, 1, InStr(1, s, "_") - 1), Len(Mid(s, 1, InStr(1, s, "_") - 1)) - 6) + " " & Left(Mid(s, InStr(1, s, "_") + 1, Len(s)), 2) + ":" + Mid(Mid(s, InStr(1, s, "_") + 1, Len(s)), 3, 2) + ":" + Right(Mid(s, InStr(1, s, "_") + 1, Len(s)), Len(Mid(s, InStr(1, s, "_") + 1, Len(s))) - 4)




'MsgBox (s1)
'
'Dim dateval As Date
''
'dateval = CDate(s)
'MsgBox (dateval)
'MsgBox (s)

'MsgBox (CDate(s))

Dim differenceinseconds As Long
differenceinseconds = DateDiff("s", CDate(s), Now)
timelapsefromnow = (differenceinseconds)


End Function

Sub test()
Dim name As String

Dim s()
s = Array("Canada", "Germany", "France")
For l = LBound(s) To UBound(s)

name = getlatestfile((s(l)))
MsgBox (name)

Next l




End Sub