CODEWITHSUNDEEP
excelvbaoutlookemail-attachments
Rob E
Rob E

Reputation: 35

Is there a VBA formula to combine row return based on cell value with Outlook email creation to multiple recipients?

I have a workbook ("All Data") with multiple sheets. This workbook is massive and takes 3 minutes to load. As a result I need to open using pathway, then delay for 3 minutes before commencing the extract.

I want to extract rows from one sheet ("Contents"), based on column B ("Names"). I only want to extract certain columns values from each returned row. This I can do. The next part I am struggling with.

I have a separate look up table sheet ("Staff email") on the. xlsm ("Performance. xlsm") whereby each person in "Names" has a corresponding email address. Eg "John" in A2, and "[email protected]") in B2. I need the macro to search for "John" in the target WS, extract all rows with "John" in the stated column, then create an Outlook email to John's email (using a lookup from the "Staff email" table) and attach a single sheet on a . xlsx to the email named "Immediate Action Needed) to the email, and send it. Then I need the macro to loop down to the next name on the" Staff email" table (eg "Janet" on cell A3) and repeat the process. If the search looks for a name on the target sheet, and does not find it, I don't want the macro to generate an email. At the end of the run, I want a text box to state the names of the staff who were emailed. Previously I have tried to manually copy the values on "Contents" to my. xlsm and running purely from there. The formula below uses this principle, but thus is a clumsy inelegant solution:

Sub ExampleCode()
    Dim fCell As Range
    Dim wsSearch As Worksheet
    Dim wsDest As Worksheet
    Dim lastRow As Long
    'What sheet are we searching?
    Set wsSearch = Worksheets("Contents")
    'Where should we move the data?
    Set wsDest = Worksheets("Johns Actions") 
    
    'Prevent screen flicker
    Application.ScreenUpdating = False
    
    'We will be searching col B
    With wsSearch.Range("B:B")
        'Find the word "John"
        Set fCell = .Find(what:="finished", LookIn:=xlValues, lookat:=xlWhole, MatchCase:=False)
        
        'Repeat until we've moved all the records
        Do Until fCell Is Nothing
            'Found something, copy and delete
           
            'Where will we paste to?
            lastRow = wsDest.Cells(.Rows.Count, "A").End(xlUp).Offset(1).Row
            
            'Copy A:O at first. We will do Paste Values so CF doesn't get included
            wsSearch.Cells(fCell.Row, "A").Resize(1, 15).Copy
            wsDest.Cells(lastRow, "A").PasteSpecial Paste:=xlPasteValues
            'Now grab AF:AG
            wsSearch.Cells(fCell.Row, "AF").Resize(1, 2).Copy
            wsDest.Cells(lastRow, "P").PasteSpecial Paste:=xlPasteValues
            
            fCell.EntireRow.Delete
            
            'Try to find next one
            Set fCell = .Find(what:="finished", LookIn:=xlValues, lookat:=xlWhole, MatchCase:=False)
        Loop
        
        'Resize our table to match new data
        If lastRow <> 0 Then
            wsDest.ListObjects("Table2").Resize wsDest.Range("A4:AG" & lastRow)
        End If
    End With
    
    'Reset
    Application.ScreenUpdating = True
    
End Sub

Upvotes: 0

Views: 64

Answers (1)

Eugene Astafiev
Eugene Astafiev

Reputation: 49455

There is no ready-made solution for that. You need to develop/create the code to process worksheet data and send the email for you if the required entries are listed on the worksheet.

Upvotes: 0

Related Questions