Hi,
I am getting an Error while sending Mails. It is showing me Sub or Function not defined.
Please Help
Below is the code
HTML
Sub C_Gen()
Dim Curr, Mac As Workbook
Dim wbData, M, Nac As Worksheet
Dim wsCrit As Worksheet
Dim wbNew As Worksheet
Dim bng As Range
Dim lastrow As Long
Dim Cur As Workbook
Dim QS As Worksheet
Dim a, b, c, D, Name, PT, x, y, z
Dim StringTo As String, StringCC As String, StringBCC As String
Dim AB
Dim ShArr() As String, FArr() As String, strDate As String
Dim myCell As Range, cell As Range, rng As Range, Fname As String, Fname2 As String
Dim wb As Workbook, sh As Worksheet
Dim DefPath As String
Dim olApp As Object
Dim olMail As Object
Dim FileExtStr As String
Dim ToArray As Variant
Dim CCArray As Variant
Dim BCCArray As Variant
Dim StringFileNames As String
Dim StringSheetNames As String
Dim FileNamesArray As Variant
Dim SheetNamesArray As Variant
Dim I As Long, S As Long, F As Long
Dim WrongData As Boolean
Set Curr = Application.ActiveWorkbook
Sheets("M").Select
Set M = Application.ActiveSheet
M.Activate
Curr.Activate
Set Nac = Application.ActiveSheet
Nac.Activate
Set wsCrit = Worksheets.Add
Nac.Activate
lastrow = Range("A" & Rows.Count).End(xlUp).Row
Nac.Range("A2:A3004").AdvancedFilter Action:=xlFilterCopy, CopyToRange:=wsCrit.Range("A1"), Unique:=True
Set bng = wsCrit.Range("A2")
While bng.Value <> ""
Set wbNew = Worksheets.Add
Nac.Range("A2:P" & lastrow).AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=bng.Offset(-1).Resize(2), CopyToRange:=wbNew.Range("A1"), Unique:=True
wbNew.Name = "TP"
Range("B2:P12").Select
Selection.Copy
Worksheets("E").Select
Range("A3").Select
Selection.PasteSpecial Paste:=xlPasteValues
bng.EntireRow.Delete
Set bng = wsCrit.Range("A2")
Application.DisplayAlerts = False
Sheets("TP").Delete
Application.DisplayAlerts = True
If Len(ThisWorkbook.Path) = 0 Then
MsgBox "This macro will only work if the file is Saved once", 48, "Qaiyum Shaikh"
Exit Sub
End If
If ActiveSheet.ProtectContents = True Or ActiveWindow.SelectedSheets.Count > 1 Then
MsgBox "This macro will not work if the Qaiyum is " & _
"protected or if you have more then sheet selected(grouped)", 48, "Qaiyum"
Exit Sub
End If
'Set folder where we save the temporary files
DefPath = Application.DefaultFilePath
If Right(DefPath, 1) <> "\" Then
DefPath = DefPath & "\"
End If
'Set reference to Outlook and turn of ScreenUpdating and Events
Set olApp = CreateObject("Outlook.Application")
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
Range("P2").Select
'Set cells with Red interior color to no fill(cells with wrong data)
'Set rng to the first column of the table
Set rng = ActiveSheet.Range("P3")
For Each myCell In rng
'Create mail if "Yes " in column A
If LCase(myCell.Value) = "yes" Then
StringTo = "": StringCC = "": StringBCC = ""
S = 0: F = 0
Erase ShArr: Erase FArr
'Set Error Boolean to False
WrongData = False
'Check to Mail addresses in column D
If Trim(ActiveSheet.Cells(myCell.Row, "Q").Value) <> "" Then
StringTo = ActiveSheet.Cells(myCell.Row, "Q").Value
ToArray = Split(StringTo, Chr(10), -1)
StringTo = ""
For I = LBound(ToArray) To UBound(ToArray)
If ToArray(I) Like "?*@?*.?*" Then
StringTo = StringTo & ";" & ToArray(I)
End If
Next I
End If
'Check to Mail addresses in column E
If Trim(ActiveSheet.Cells(myCell.Row, "R").Value) <> "" Then
StringCC = ActiveSheet.Cells(myCell.Row, "R").Value
CCArray = Split(StringCC, Chr(10), -1)
StringCC = ""
For I = LBound(CCArray) To UBound(CCArray)
If CCArray(I) Like "?*@?*.?*" Then
StringCC = StringCC & ";" & CCArray(I)
End If
Next I
End If
'Check to Mail addresses in column F
If Trim(ActiveSheet.Cells(myCell.Row, "S").Value) <> "" Then
StringBCC = ActiveSheet.Cells(myCell.Row, "S").Value
BCCArray = Split(StringBCC, Chr(10), -1)
StringBCC = ""
For I = LBound(BCCArray) To UBound(BCCArray)
If BCCArray(I) Like "?*@?*.?*" Then
StringBCC = StringBCC & ";" & BCCArray(I)
End If
Next I
End If
If StringTo = "" And StringCC = "" And StringBCC = "" Then
ActiveSheet.Cells(myCell.Row, "D").Resize(, 3).Interior.ColorIndex = 3
WrongData = True
End If
'Check the other files that you want to attach in column H
If Trim(ActiveSheet.Cells(myCell.Row, "T").Value) <> "" Then
StringFileNames = ActiveSheet.Cells(myCell.Row, "T").Value
FileNamesArray = Split(StringFileNames, Chr(10), -1)
For I = LBound(FileNamesArray) To UBound(FileNamesArray)
On Error Resume Next
If FileNamesArray(I) <> "" Then
If Dir(FileNamesArray(I)) <> "" Then
If Err.Number = 0 Then
F = F + 1
ReDim Preserve FArr(1 To F)
FArr(F) = FileNamesArray(I)
Else
Err.Clear
ActiveSheet.Cells(myCell.Row, "T").Interior.ColorIndex = 3
WrongData = True
End If
Else
ActiveSheet.Cells(myCell.Row, "T").Interior.ColorIndex = 3
WrongData = True
End If
End If
On Error GoTo 0
Next I
End If
'Not create the mail if there are Errors in the row (wrong sheet or file names or no mail addresses)
If WrongData = True Then GoTo MailNot
Set rng = Sheets("E").Range("A1:O3").SpecialCells(xlCellTypeVisible)
' Set AB = Me.Range("O2:Z4").SpecialCells(xlCellTypeVisible)
On Error Resume Next
Set olMail = olApp.CreateItem(0)
With olMail
.To = StringTo
.CC = StringCC
.BCC = StringBCC
.Subject = ActiveSheet.Cells(myCell.Row, "U").Value
.HTMLBody = "<HTML> <br> </br> </HTML>" & "<html><b>Hi,</b></html>" & "<HTML> <br> </br> </HTML>" _
& " <html><b> " _
& "Please find below summary on Cash Indent and Cash Received.</b></html>" _
& "<HTML> <br> </br> </HTML>" & "<html><b><u> If any discrepancies observed, " _
& "please highlight us for further investigations & rectifications. </b></u> </html>" & _
"<HTML> <br> </br> </HTML>" & rangetoHTML(rng) & "<HTML> <br> </br> </HTML>" & _
"<html><b>Thanks & Regards</b></html>" & "<HTML> <br> </br> </HTML>" & "<b> NCR Corporation (Cash Team) </b>"
.display
'If S <> 0 Then .Attachments.Add Fname
If F > 0 Then
For I = LBound(FArr) To UBound(FArr)
.Attachments.Add FArr(I)
Next I
End If
'Set Importance 0 = Low, 2 = High, 1 = Normal
If LCase(ActiveSheet.Cells(myCell.Row, "V").Value) = "yes" Then
.Importance = 2
End If
'Display the mail or send it directly, see cell C3
If LCase(ActiveSheet.Range("Q1").Value) = "yes" Then
.display
Else
.Send
End If
End With
If S = -1 Then Kill Fname2
Kill Fname
On Error GoTo 0
Set olMail = Nothing
End If
MailNot:
Next myCell
If LCase(ActiveSheet.Range("V3").Value) = "no" Then
MsgBox "The macro is ready and if correct the mail or mails are created." & vbNewLine & _
"If you see Red cells in the table then the information in the cells is " & vbNewLine & _
"not correct. For example there is a sheet or filename that not exist." & vbNewLine & _
"Note: It will not create a Mail of the information in a row with a " & vbNewLine & _
"Red cell or cells.", 48, "Macro Help"
End If
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
Set olApp = Nothing
Nac.Activate
Wend
End
End Sub