Filter data as per given criteria in list

[Mohammad Shafaat]

Hi Please help
i want to filter data as per given criteria in list (mentioned any where in file) from base and send to a new mail and also same attached as image in mail body. and send
base file is attached for reference.

Thankyou.

<< Modify Your Title as written in Forum Rules >>
<< USE CODE -TAGS >>

Sub sendmail()
'' sendmail Macro'
Dim dte As Date
Dim mon As Integer
Dim yr As Integer
Dim mailcount As Integer
Dim filtercol As Integer
Dim Maildb As Object
Dim MailDoc As Object
Dim attachME As Object
Dim Session As Object
Dim EmbedObj1 As Object
Dim UserName As String
Dim MailDbName As String
Dim recipient As String
Dim ccRecipient As String
Dim bccRecipient As String
Dim subject As String
Dim finlsub As String
Dim stSignature As String
Dim addname As String
Dim bodytext As String
Dim Attachment1 As String
Dim Attachment2 As String
Dim FilName As String
Application.DisplayAlerts = False
dte = Date
mon = Month(dte)
yr = Year(dte)
Attachment2 = Range("F15").Value
Sheets("MAIL-ID").Activate
Range("AG2").Value = 0
mailcount = Range("AG14").Value
subject = Range("F2").Value
bodytext = Range("H2").Value & Chr(10) & Range("F7").Value & Chr(10) & Range("H3").Value & Chr(10) & Range("H4").Value & Chr(10) & Range("H5").Value & Chr(10)
addname = Range("F12").Value
If mon <= 12 Then GoTo validated 'Else If mon >= 12 Then GoTo exitsubexitsub: If UCase(Environ$("USERDOMAIN")) <> "domain" Then MsgBox "This is not your copy of Filtermails " & Chr(10) & "You are an UNAUTHORISED USER ", vbCritical
Exit Sub
validated: If mailcount = 0 Then MsgBox "There are no recepients in your list.", vbCritical, "WHAT ARE YOU DOING?"
For x = 0 To (mailcount - 1)
Sheets("MAIL-ID").Select
Range("AG2").Value = x + 1
FilName = (Environ$("cpinfo")) & "\cpinfo.xls"
If Dir(FilName) <> "" Then
Kill FilName
End If
filtercol = Range("G2").Value
Range("AG4").Select
Selection.Copy
Range("AG7").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
  :=False, Transpose:=False
Application.CutCopyMode = False
recipient = Range("AG7").Value
Range("AG5").Select
Selection.Copy
Range("AG8").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
  :=False, Transpose:=False
Application.CutCopyMode = False
ccRecipient = Range("AG8").Value
If ccRecipient = "0" Then
ccRecipient = ""
End If
Range("AG6").Select
Selection.Copy
Range("AG9").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
  :=False, Transpose:=False
Application.CutCopyMode = False
bccRecipient = Range("AG9").Value
If bccRecipient = "0" Then
bccRecipient = ""
End If
Range("AG3").Select
Selection.Copy
Range("AG11").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
Range("AG11").Copy (Sheets("DATA").Range("O60000"))
Sheets("DATA").Select
If addname = "YES" Then
finlsub = subject & " ( " & Range("O60000").Value & " )"
finlbody = "Dear " & Range("O60000").Value & Chr(10) & Chr(10) & bodytext
End If
If addname = "NO" Then
finlsub = subject
finlbody = bodytext
End If
Range("A1").Select
If Range("a1") = "" Then
MsgBox "NO or Wrong arrangement of Data in DATA Sheet", vbCritical
Exit For
End If
Selection.AutoFilter
Selection.AutoFilter field:=filtercol, Criteria1:= _
Range("O60000").Value
Range("A1").Select
Range(Selection, Selection.End(xlDown)).Select
Range(Selection, Selection.End(xlToRight)).Select
Selection.Copy
Workbooks.Add
ActiveSheet.Paste
Cells.Select
Cells.EntireColumn.AutoFit
ActiveWorkbook.SaveAs Filename:="C:\Users\Desktop\Extra\Data.xls", FileFormat:= _
xlNormal, Password:="", WriteResPassword:="", ReadOnlyRecommended:=False _
  , CreateBackup:=False
ActiveWorkbook.Close

Dim OlApp As New Outlook.Application
Dim myNameSp As Outlook.Namespace
Dim myInbox As Outlook.MAPIFolder
Dim myExplorer As Outlook.Explorer
Dim NewMail As Outlook.MailItem
Dim OutOpen As Boolean


  OutOpen = True
  Set myExplorer = OlApp.ActiveExplorer
  If TypeName(myExplorer) = "Nothing" Then
  OutOpen = False
  Set myNameSp = OlApp.GetNamespace("MAPI")
  Set myInbox = myNameSp.GetDefaultFolder(olFolderInbox)
  Set myExplorer = myInbox.GetExplorer
  End If
  'myExplorer.Display ' You don't have to show Outlook to use it
  ' Create a new mail message item.  Set NewMail = OlApp.CreateItem(olMailItem)
  With NewMail
  '.Display ' You don't have to show the e-mail to send it.To = recipient
.CC = ccRecipient
.BCC = bccRecipient
.subject = finlsub
.body = finlbody & vbCrLf & vbCrLf & stSignature
.Attachments.Add ("C:\Users\Desktop\Extra\Data.xls")

  End With

  NewMail.Send
  If Not OutOpen Then OlApp.Quit

  'Release memory.  Set OlApp = Nothing
  Set myNameSp = Nothing
  Set myInbox = Nothing
  Set myExplorer = Nothing
  Set NewMail = Nothing
  recipient = ""
  ccRecipient = ""
  bccRecipient = ""
  finlsub = ""
  FilName = ""

'finlsub = Nullfinlbody = Null
Next
Sheets("MAIL-ID").Activate
Range("A1").Select
MsgBox "Thank you for using this MACRO"
End Sub