Sending Email through outlook with saving Excel file

[atulvij89]

Hi everyone,

I am trying to send email to responsible person in Excel file by creating new workbook with some details and sending to responsible prerson but my code is not saving file and poping up window for email.

Please tell what is the error in file and how i can optiomise it

Sub Backup_required()
Dim OutlookApp, MItem As Object
Dim cell As Range
Dim Subj As String
Dim EmailAddr As String
Dim Recipient As String
Dim Msg As String
Dim ws As Worksheet, ws2 As Worksheet, ws3 As Worksheet
Dim wb As Workbook, wb2 As Workbook
Dim main_book As String
Dim newWorkbook As String
Application.DisplayAlerts = False
'create outblook object
Set OutlookApp = CreateObject("Outlook.Application")
Application.ScreenUpdating = False
'defines the user name
user = Environ("username")
main_book = ActiveWorkbook.Name
Set wb = Workbooks(main_book)
'email subject
Subj = "Blackline Reconciliation - Backup Required!"
 
  
Call pathDefinition
'operation for all sheets in BS_Download template with comments
For Each g In Workbooks(main_book).Worksheets
Set ws = wb.Worksheets(g.Name)
If g.Name <> "Sap Data" And g.Name <> "Automated BL Import" Then
lastRow = ws.Range("B" & Rows.Count).End(xlUp).Row
'select every cells in all sheets in BS_Download template with comments
For Each a In ws.Range("W2:W" & lastRow)
If Left(a, 1) <> "*" And a.Value <> 0 And a.Offset(0, 1).Value = 0 Then
B = a.Row
f = a.Value
'add new book where the cell with met conditions are copied
Workbooks.Add
newWorkbook = ActiveWorkbook.Name
Workbooks(newWorkbook).Worksheets(1).Range("A1:AA1").Value = ws.Range("A1:AA1").Value
Set wb2 = Workbooks(newWorkbook)
Set ws3 = wb2.Worksheets(1)
'select all cells in all sheets in BS_Download template with comments
For Each d In Workbooks(main_book).Worksheets
If d.Name <> "Sap Data" And d.Name <> "Automated BL Import" Then
Set ws2 = wb.Worksheets(d.Name)
'compare if condition is met in all cells in all sheets in BS_Download template with comments
lastRow2 = ws2.Range("B" & Rows.Count).End(xlUp).Row
For Each e In ws2.Range("W2:W" & lastRow2)
C = e.Row
If e.Value = f And Left(e, 1) <> "*" And e.Offset(0, 1) = 0 Then
lastRow3 = ws3.Range("B" & Rows.Count).End(xlUp).Row + 1
ws3.Range("A" & lastRow3, "AA" & lastRow3).Value = ws2.Range("A" & C, "AA" & C).Value
e.Value = "*" & e.Value
If Left(a, 1) <> "*" Then
a.Value = "*" & a.Value
End If
End If
Next e
End If
  
Next d
ws3.Range("A1:AA1").Interior.Color = RGB(51, 102, 255)
ws3.Columns("A:AA").EntireColumn.AutoFit
'finally save the new opened workbook with name of compared a cell
wb2.SaveAs FileName:=var  & "\" & f & ".xlsx", _
FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
wb2.Close
EmailAddr = f
'open new email
Set MItem = OutlookApp.CreateItem(olMailItem)
Set myAttachments = MItem.Attachments
With MItem
.To = EmailAddr
.Subject = Subj
.Display
End With
'paste the attachment of new workbooks save on user desktop
myAttachments.Add  var & "\" & f & ".xlsx"
End If
Next a
End If
Next g
'erase the first left "*" in all the cell in T column
For Each a In Workbooks(main_book).Worksheets
Set ws = wb.Worksheets(a.Name)
If a.Name <> "Sap Data" And a.Name <> "Automated BL Import" Then
lastRow = ws.Range("B" & Rows.Count).End(xlUp).Row
For Each B In ws.Range("W2:W" & lastRow)
If Left(B, 1) = "*" Then
B.Value = Right(B, (Len(B.Value) - 1))
End If
Next B
End If
Next a
Application.DisplayAlerts = True
End Sub