Automating searching mails in outlook with a particular word in the subject,copy the mail message and the sender's mail address in an existing excel file,VBA Teacher Sourav,Kolkata 09748184075

Sub CloseOutlook()
Dim OL As Object
On Error Resume Next
Set OL = GetObject(, "Outlook.Application")
On Error GoTo 0
If OL Is Nothing Then
'MsgBox "Outlook is not running!"
Else
OL.Quit
End If
End Sub


 Sub Search_Inbox()
 'Optimize Macro Speed
  Application.ScreenUpdating = False
  Application.EnableEvents = False
  Application.Calculation = xlCalculationManual
  Dim wb As Workbook
 'Trying to close outlook first

 CloseOutlook
 'Trying to close the target excel file

    'now let's see if the workbook where the data to be pasted is open or not
       
         Dim status As Boolean

         status = IsWorkBookOpen("C:\Users\sourav\Desktop\data.xlsm")
         If status = True Then
         Workbooks("data.xlsm").Close SaveChanges:=True
        
         End If
       

Dim myOlApp As New Outlook.Application
Dim myNameSpace As Outlook.Namespace
Dim myInbox As Outlook.MAPIFolder
Dim myitems As Outlook.Items
Dim myItem As Object
Dim Found As Boolean
Dim atmt As Outlook.Attachment
Dim MyAr() As String
Dim address As String
Dim message As String


Dim ws As Worksheet
Dim aCell As Range, Rng As Range
Dim col As Long, lRow As Long
Dim colName As String
On Error Resume Next

Set myNameSpace = myOlApp.GetNamespace("MAPI")
Set myInbox = myNameSpace.GetDefaultFolder(olFolderInbox)
Set myitems = myInbox.Items
Found = False

For Each myItem In myitems
    If myItem.Class = olMail Then
        If InStr(1, myItem.Subject, "macro") > 0 Then
            'MsgBox ("Found")
            For Each atmt In myItem.Attachments

                If atmt.FileName = "macro.txt" Then
                    atmt.SaveAsFile "D:\" & atmt.FileName
                    'MsgBox (myItem.SenderEmailAddress)
                    'saving the mail body in an array
               
                    MyAr = Split(myItem.Body, vbCrLf)

                    For i = LBound(MyAr) To UBound(MyAr)
                        '~~> This will give you the contents of your email
                        '~~> on separate lines
                        'MsgBox (MyAr(i))
                        If MyAr(i) <> "" Then
                        message = message + MyAr(i)
                        End If
   
   
                    Next i

                    'Now trying to write the message and the sender address in an existing excel file

                    'First trying to close the file if it is already open
                    On Error Resume Next

                    Workbooks("data.xlsm").Close SaveChanges:=True

                    'now trying to open the file

                    Set wb = Workbooks.Open("C:\Users\sourav\Desktop\data.xlsm")
                    'now finding the spicific column with some word or words
                    Set ws = wb.Sheets("Sheet2")

                    With ws
                        Set aCell = .Range("A1:P1").Find(What:="Mail*", LookIn:=xlValues, LookAt:=xlWhole, _
                        MatchCase:=False, SearchFormat:=False)
                        If Not aCell Is Nothing Then
                            col = aCell.Column
                            colName = Split(.Cells(, col).address, "$")(1)
                            'MsgBox (colName)

                            lRow = .Range(colName & .Rows.count).End(xlUp).Row
                            'MsgBox (lRow)
           
                            '~~> This is your range
                            'Set Rng = .Range(colName & "8:" & colName & lRow)

                            'MsgBox (Rng.address)
                            '~~> If not found
       
                            'Now find the blank cell in the column found earlier
                            Set Rng = .Range(colName & lRow)
                            Rng.Select
       
                             Range(Selection.End(xlDown)).Select
                             ActiveCell.Offset(1, 0).Select
                            
                           
                            ActiveCell.Value = myItem.SenderEmailAddress
                            If ActiveCell.Offset(0, 1) = "" Then
                                ActiveCell.Offset(0, 1).Value = message
                            End If
                            ws.Columns.AutoFit
                        Else
                            ' MsgBox "Mail Not Found"
                        End If
                        End With
                        On Error Resume Next
                        wb.Close SaveChanges:=True
                        Set wb = Nothing
                        Set ws = Nothing
                       
                        'MsgBox ("Done")

                End If


                message = ""
            Next
                Found = True
        End If
    End If
Next myItem

'If the subject isn't found:
If Not Found Then
   ' NoResults.Show
   MsgBox ("Task Failed")
  
End If

myOlApp.Quit
Set myOlApp = Nothing


'Reset Macro Optimization Settings
    Application.EnableEvents = True
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
End Sub