send e-mail from excel under conditions (automatically)

[whitoulias]

Sub email()
Dim myOutlook As Object
Dim myMailItem As Object
Dim FName As String
Set otlApp = CreateObject("Outlook.Application")
Set otlNewMail = otlApp.CreateItem(olMailItem)
FName = ActiveWorkbook.Path & "\" & ActiveWorkbook.Name
With otlNewMail
.To = "xxx@www.com;xxx1@www.com"
.CC = ""
.Subject = "new itens "
.Body = "Attached you may find new items expiring in 7 days"
.Attachments.Add FName
.DeferredDeliveryTime = Range("I2")
.Send
End With
 
Set otlNewMail = Nothing
Set otlApp = Nothing
Set otlAttach = Nothing
Set otlMess = Nothing
Set otlNSpace = Nothing
End Sub

Good day to all

This code runs fine in order to send an e-mail from outlook while i'm in excel.
I would like to change it a bit

The excel has 4 sheets.

The third sheet is named "new items".

In this sheet in COLUMN K i have numbers and empty cells.

What i would like is when in COLUMN K number "7" exists then copy the enire row- and all other rows with "7" to a new excel named "new items" and send an e-mail to specific receipients with "new items" attached.

I will change the code above in order to run this macro by workbook.open()

Plus i'm thinking of adding a message box if no "7"'s exist

Any thoughts?
Thank you

 

[whitoulias]

Sub Transfer()
    Dim c As Long
    Dim wsD As Worksheet: Set wsD = Worksheets("new items")    'Data Worksheet.
    Dim wsR As Worksheet: Set wsR = Worksheets("xxx")    'Results Worksheet
    
    For c = 2 To 3002    'Loop through 3000 records.
        With wsD.Range("K" & c)
            If .Value = 7 Then    'Test for 7.
                wsD.Range("B" & c & ":S" & c & "").Copy
                wsR.Activate
                wsR.Range("A" & wsR.Range("A" & Rows.Count).End(xlUp).Row + 1).Select
                Selection.PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:=xlNone, SkipBlanks _
                                                                              :=False, Transpose:=False
                
                        End If
              End With
    Next c

In addition i have also the code for copy paste rows with 7 but to a new sheet in the same excel

Can i somehow combine both?

 

[whitoulias]

Private Sub Workbook_Open()
Application.DisplayAlerts = False
Dim myOutlook As Object
Dim myMailItem As Object
Dim FName As String
FName = ActiveWorkbook.Path & "\" & ActiveWorkbook.Name
Set otlApp = CreateObject("Outlook.Application")
Set otlNewMail = otlApp.CreateItem(olMailItem)

Dim c As Long
Dim wsn As Worksheet: Set wsn = Sheets.Add
Dim wsD As Worksheet: Set wsD = Worksheets("data entry")    'Data Worksheet.
Dim wsR As Worksheet: Set wsR = wsn    'Results Worksheet
        For c = 2 To 3002    'Loop through 3000 records.
        With wsD.Range("K" & c)
            If .Value = 7 Then    'Test for 7.
                wsD.Range("B" & c & ":L" & c & "").Copy
                wsR.Activate
                wsR.Range("A" & wsR.Range("A" & Rows.Count).End(xlUp).Row + 1).Select
                Selection.PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:=xlNone, SkipBlanks _
                                                                              :=False, Transpose:=False
                        End If
              End With
    Next c
    
  If WorksheetFunction.CountA(Cells) = 0 Then
  MsgBox "NO NEW ITEMS"
  Sheets("Sheet1").Delete
  Else
  With otlNewMail
.To = "XXX@ONE.com;XXX1@one.com"
.CC = ""
.Subject = "new items "
.Body = "Attached you may find new items expiring in 7 days"
.Attachments.Add FName
.DeferredDeliveryTime = Range("I2")
.Send
End With
 
Set otlNewMail = Nothing
Set otlApp = Nothing
Set otlAttach = Nothing
Set otlMess = Nothing
Set otlNSpace = Nothing

 End If
  

End Sub

I've reached it to the point where if "7" exists a new sheet is created with all the necassery data.

Does any know how can i attach only sheet 1 in the e-mail?

thx

 

[joopw]

Hi,

Check Ron de Bruin's articles on Microsoft Office Developer Center (MSDN)

Using VBA in Excel to Send Workbooks and Ranges through E-Mail with Outlook (Part 1 of 2)
Using VBA in Excel to Send Workbooks and Ranges through E-Mail with Outlook (Part 2 of 2)

 

[whitoulias]

Private Sub Workbook_Open()
Application.DisplayAlerts = False
Dim myOutlook As Object
Dim myMailItem As Object
Set otlApp = CreateObject("Outlook.Application")
Set otlNewMail = otlApp.CreateItem(olMailItem)

Dim c As Long
Dim wsn As Worksheet: Set wsn = Sheets.Add
Dim wsA As Worksheet: Set wsA = Worksheets("data entry")
Dim wsR As Worksheet: Set wsR = wsn    'Results Worksheet
        For c = 2 To 3002    'Loop through 3000 records.
        With wsD.Range("K" & c)
            If .Value = 7 Then    'Test for 7.
                wsD.Range("B" & c & ":L" & c & "").Copy
                wsR.Activate
                wsR.Range("A" & wsR.Range("A" & Rows.Count).End(xlUp).Row + 1).Select
                Selection.PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:=xlNone, SkipBlanks _
                                                                              :=False, Transpose:=False
                        End If
              End With
    Next c
    
  If WorksheetFunction.CountA(Cells) = 0 Then
  MsgBox "No New Items"
  Sheets("Sheet1").Delete
  Else
  ActiveSheet.Copy
  ActiveWorkbook.SaveAs "expiring"
  Columns(1).Hidden = True
  Columns(10).Hidden = True
  Columns(11).Hidden = True
   With otlNewMail
.To = "xxx@one.com;xxx1@one.com"
.CC = ""
.Subject = "EXPIRING_ITEMS "
.Body = "Attached you may find new items expiring in 7 days"
.Attachments.Add ActiveWorkbook.FullName
.DeferredDeliveryTime = Range("I2")
.Send
End With
 
Set otlNewMail = Nothing
Set otlApp = Nothing
Set otlAttach = Nothing
Set otlMess = Nothing
Set otlNSpace = Nothing

 End If
  

End Sub

I'm pasting the code just for the record

This macro will find number "7" in column k
copy the selected cells from that row to a new workbook
send e-mail with the new workbook attached