Send Email Automatically

drubin25

Board Regular
Joined
Mar 19, 2016
Messages
62
I want to send an email when certain conditions are met, and it tells me an object is required.

If cell D26 = "SEND TO OFFICE TO CREATE A BACKORDER" I am looking to send the email out, but I am not sure what is wrong.

VBA Code:
Sub SENDTOLOG_Click()
'
''    Application.ScreenUpdating = False
'
Dim CS As Worksheet, PS As Worksheet, lr As Long        ' , M As Long
    Dim LineQuantity        As Long
    Dim QtyRejected         As Long
    Dim TicketLoadDate      As String
    Dim ArSourceAddress()   As Variant
    Dim CustName            As Variant
    Dim POnumber            As Variant
    Dim RejectedBy          As Variant
    Dim SpecialBatchNumber  As Variant
'
    Set CS = Worksheets("Input")
    Set PS = Worksheets("Records")
'
    If CS.Range("G4") = "" Then
        Do
            CustName = Application.InputBox(Prompt:="Please enter the CUSTOMER NAME" & vbCrLf & " " & vbCrLf & "Por Favor, Introduzca el NOMBRE DEL CLIENTE")  ' Text entry
        Loop Until CustName <> vbNullString And CustName <> False
'
        CS.Range("G4").Value = CustName
    End If
'
    If CS.Range("G7") = "" Then
        Do
            LineQuantity = Application.InputBox(Prompt:="Please enter the LINE QUANTITY" & vbCrLf & " " & vbCrLf & "Por Favor, introduzca la CANTIDAD DE LÍNEA", Type:=1)  ' Numeric Entry
        Loop Until LineQuantity <> 0 And LineQuantity <> False
'
        CS.Range("G7").Value = LineQuantity
    End If
'
    If CS.Range("M7") = "" Then
        Do
            QtyRejected = Application.InputBox(Prompt:="Please enter the QTY REJECTED" & vbCrLf & " " & vbCrLf & "Por Favor, introduzca el QTY RECHAZADO   ", Type:=1)    ' Numeric Entry
        Loop Until QtyRejected <> 0 And QtyRejected <> False
'
        CS.Range("M7").Value = QtyRejected
    End If
'
    If CS.Range("G14") = "" Then
        Do
            TicketLoadDate = Application.InputBox(Prompt:="Please enter the TICKET LOAD DATE" & vbCrLf & " " & vbCrLf & "Por Favor, introduzca la FECHA DE CARGA DEL BILLETE")      ' Date Entry
        Loop Until IsDate(TicketLoadDate) = True
'
        CS.Range("G14").Value = TicketLoadDate
    End If
'
    If CS.Range("M14") = "" Then
        Do
            RejectedBy = Application.InputBox(Prompt:="Please enter your name in the REJECTED BY: BOX" & vbCrLf & " " & vbCrLf & "Por Favor, introduzca su nombre en la CASILLA RECHAZADO POR") ' Text entry
        Loop Until RejectedBy <> vbNullString And RejectedBy <> False
'
        CS.Range("M14").Value = RejectedBy
    End If
'
    If CS.Range("G20") = "" Then
        Do
            POnumber = Application.InputBox(Prompt:="Please enter the PO NUMBER" & vbCrLf & " " & vbCrLf & "Por Favor, introduzca el Numero de Orden de Compra")  ' Text entry
        Loop Until POnumber <> vbNullString And POnumber <> False
'
        CS.Range("G20").Value = POnumber
    End If
'
    If CS.Range("D26").Value = "CREATE SPECIAL BATCH" Then
        MsgBox ("YOU MUST CREATE A SPECIAL BATCH" & vbCrLf & " " & vbCrLf & "DEBE CREAR UN LOTE ESPECIAL")
'
        Do
            SpecialBatchNumber = Application.InputBox(Prompt:="ENTER THE SPECIAL BATCH TICKET NUMBER THAT WAS CREATED: " & vbCrLf & "INTRODUZCA EL NÚMERO DE TICKET DE LOTE ESPECIAL QUE SE CREÓ:") ' Text entry
        Loop Until SpecialBatchNumber <> vbNullString And SpecialBatchNumber <> False
'
        lr = PS.Range("A" & PS.Rows.Count).End(xlUp).Row + 1            ' Find First Empty Row after Data

        PS.Range("R" & lr).Value = SpecialBatchNumber
    End If
'
    If CS.Range("D26").Value = "DO NOT CREATE A SPECIAL BATCH AND DO NOT BACKORDER." & vbCrLf & " " & vbCrLf & "NO CREE UN LOTE ESPECIAL Y NO REALICE PEDIDOS PENDIENTES" Then
        MsgBox ("DO NOT CREATE A SPECIAL BATCH AND DO NOT BACKORDER. NOTHING IS REQUIRED OF YOU FOR THIS ITEM." & vbCrLf & " " & vbCrLf & "NO CREE UN LOTE ESPECIAL Y NO REALICE PEDIDOS PENDIENTES. NO SE REQUIERE NADA DE USTED PARA ESTE ARTÍCULO")
    End If
'
    If CS.Range("D26").Value = "SEND TO OFFICE TO CREATE A BACKORDER." & vbCrLf & " " & vbCrLf & "ENVIAR A OFICINA PARA CREAR UN PEDIDO PENDIENTE" Then
    
    Call Email
'
        lr = PS.Range("A" & PS.Rows.Count).End(xlUp).Row + 1            ' Find First Empty Row after Data
'
End If
'
    lr = PS.Cells(Rows.Count, 1).End(xlUp).Row + 1                  ' Find First Empty Row after Data
'
'   Copy data from the INPUT to the RECORDS worksheet
    ArSourceAddress = Array("M4", "G4", "D17", "G14", "G7", "M7", "P7", "G11", "D26", "M14", "G20")
'
    For I = 0 To UBound(ArSourceAddress)
        PS.Cells(lr, I + 1).Value = CS.Range(ArSourceAddress(I)).Value           ' Columns 1 thru 11 .... Array addresses
    Next
'
    PS.Cells(lr, 12).Resize(, 4).Value = CS.Range("S24").Resize(, 4).Value  'Columns 12,13,14,15 .... S24,T24,U24,V24
'
    PS.Cells(lr, 16).Resize(, 2).Value = CS.Range("X24").Resize(, 2).Value  ' Columns 15,16 .... X24,Y24
'
    MsgBox "THE RECORD HAS BEEN SAVED." & vbCrLf & " " & vbCrLf & "EL REGISTRO SE HA GUARDADO."
    
    Call Email

''Application.ScreenUpdating = True

End Sub

Sub Email()

Dim oApp As Object
Dim oMail As Object
Set oApp = CreateObject("Outlook.application")
Set oMail = oApp.CreateItem(0)
With OutlookMail
    .To = "drubin@jeldwen.com"
    .CC = "drubin@jeldwen.com"
    .BCC = "drubin@jeldwen.com"
    .Subject = "ACTION REQUIRED: ENTER A BACKORDER" & CS.Range("G4").Value & "PO Number " & CS.Range("G20")
    .BodyFormat = olFormatHTML
    .HTMLBody = "Please create a backorder for the following:" & vbNewLine & vbNewLine & "Customer: " & CS.Range("G4").Value & vbNewLine & _
        "Customer #: " & CS.Range("M4").Value & vbNewLine & "Quantity: " & CS.Range("R8").Value & vbNewLine & "PO Number: " & CS.Range("G20").Value & _
        vbNewLine & vbNewLine & "Contact for Questions: " & CS.Range("M14").Value
        .Send
End With
End Sub
 

Excel Facts

How to change case of text in Excel?
Use =UPPER() for upper case, =LOWER() for lower case, and =PROPER() for proper case. PROPER won't capitalize second c in Mccartney
See if this works :


VBA Code:
Option Explicit

Sub SENDTOLOG_Click()
'
''    Application.ScreenUpdating = False
'
Dim CS As Worksheet, PS As Worksheet, lr As Long        ' , M As Long
    Dim LineQuantity        As Long
    Dim QtyRejected         As Long
    Dim TicketLoadDate      As String
    Dim ArSourceAddress()   As Variant
    Dim CustName            As Variant
    Dim POnumber            As Variant
    Dim RejectedBy          As Variant
    Dim SpecialBatchNumber  As Variant
    Dim I As Long
'
    Set CS = Worksheets("Sheet1")
    Set PS = Worksheets("Sheet2")
'
    If CS.Range("G4") = "" Then
        Do
            CustName = Application.InputBox(Prompt:="Please enter the CUSTOMER NAME" & vbCrLf & " " & vbCrLf & "Por Favor, Introduzca el NOMBRE DEL CLIENTE")  ' Text entry
        Loop Until CustName <> vbNullString And CustName <> False
'
        CS.Range("G4").Value = CustName
    End If
'
    If CS.Range("G7") = "" Then
        Do
            LineQuantity = Application.InputBox(Prompt:="Please enter the LINE QUANTITY" & vbCrLf & " " & vbCrLf & "Por Favor, introduzca la CANTIDAD DE LÍNEA", Type:=1)  ' Numeric Entry
        Loop Until LineQuantity <> 0 And LineQuantity <> False
'
        CS.Range("G7").Value = LineQuantity
    End If
'
    If CS.Range("M7") = "" Then
        Do
            QtyRejected = Application.InputBox(Prompt:="Please enter the QTY REJECTED" & vbCrLf & " " & vbCrLf & "Por Favor, introduzca el QTY RECHAZADO   ", Type:=1)    ' Numeric Entry
        Loop Until QtyRejected <> 0 And QtyRejected <> False
'
        CS.Range("M7").Value = QtyRejected
    End If
'
    If CS.Range("G14") = "" Then
        Do
            TicketLoadDate = Application.InputBox(Prompt:="Please enter the TICKET LOAD DATE" & vbCrLf & " " & vbCrLf & "Por Favor, introduzca la FECHA DE CARGA DEL BILLETE")      ' Date Entry
        Loop Until IsDate(TicketLoadDate) = True
'
        CS.Range("G14").Value = TicketLoadDate
    End If
'
    If CS.Range("M14") = "" Then
        Do
            RejectedBy = Application.InputBox(Prompt:="Please enter your name in the REJECTED BY: BOX" & vbCrLf & " " & vbCrLf & "Por Favor, introduzca su nombre en la CASILLA RECHAZADO POR") ' Text entry
        Loop Until RejectedBy <> vbNullString And RejectedBy <> False
'
        CS.Range("M14").Value = RejectedBy
    End If
'
    If CS.Range("G20") = "" Then
        Do
            POnumber = Application.InputBox(Prompt:="Please enter the PO NUMBER" & vbCrLf & " " & vbCrLf & "Por Favor, introduzca el Numero de Orden de Compra")  ' Text entry
        Loop Until POnumber <> vbNullString And POnumber <> False
'
        CS.Range("G20").Value = POnumber
    End If
'
    If CS.Range("D26").Value = "CREATE SPECIAL BATCH" Then
        MsgBox ("YOU MUST CREATE A SPECIAL BATCH" & vbCrLf & " " & vbCrLf & "DEBE CREAR UN LOTE ESPECIAL")
'
        Do
            SpecialBatchNumber = Application.InputBox(Prompt:="ENTER THE SPECIAL BATCH TICKET NUMBER THAT WAS CREATED: " & vbCrLf & "INTRODUZCA EL NÚMERO DE TICKET DE LOTE ESPECIAL QUE SE CREÓ:") ' Text entry
        Loop Until SpecialBatchNumber <> vbNullString And SpecialBatchNumber <> False
'
        lr = PS.Range("A" & PS.Rows.Count).End(xlUp).Row + 1            ' Find First Empty Row after Data

        PS.Range("R" & lr).Value = SpecialBatchNumber
    End If
'
    If CS.Range("D26").Value = "DO NOT CREATE A SPECIAL BATCH AND DO NOT BACKORDER." & vbCrLf & " " & vbCrLf & "NO CREE UN LOTE ESPECIAL Y NO REALICE PEDIDOS PENDIENTES" Then
        MsgBox ("DO NOT CREATE A SPECIAL BATCH AND DO NOT BACKORDER. NOTHING IS REQUIRED OF YOU FOR THIS ITEM." & vbCrLf & " " & vbCrLf & "NO CREE UN LOTE ESPECIAL Y NO REALICE PEDIDOS PENDIENTES. NO SE REQUIERE NADA DE USTED PARA ESTE ARTÍCULO")
    End If
'
    If CS.Range("D26").Value = "SEND TO OFFICE TO CREATE A BACKORDER." & vbCrLf & " " & vbCrLf & "ENVIAR A OFICINA PARA CREAR UN PEDIDO PENDIENTE" Then
   
    Call Email
'
        lr = PS.Range("A" & PS.Rows.Count).End(xlUp).Row + 1            ' Find First Empty Row after Data
'
End If
'
    lr = PS.Cells(Rows.Count, 1).End(xlUp).Row + 1                  ' Find First Empty Row after Data
'
'   Copy data from the INPUT to the RECORDS worksheet
    ArSourceAddress = Array("M4", "G4", "D17", "G14", "G7", "M7", "P7", "G11", "D26", "M14", "G20")
'
    For I = 0 To UBound(ArSourceAddress)
        PS.Cells(lr, I + 1).Value = CS.Range(ArSourceAddress(I)).Value           ' Columns 1 thru 11 .... Array addresses
    Next
'
    PS.Cells(lr, 12).Resize(, 4).Value = CS.Range("S24").Resize(, 4).Value  'Columns 12,13,14,15 .... S24,T24,U24,V24
'
    PS.Cells(lr, 16).Resize(, 2).Value = CS.Range("X24").Resize(, 2).Value  ' Columns 15,16 .... X24,Y24
'
    MsgBox "THE RECORD HAS BEEN SAVED." & vbCrLf & " " & vbCrLf & "EL REGISTRO SE HA GUARDADO."
   
    Call Email

''Application.ScreenUpdating = True

End Sub

Sub Email()


' Works in Excel 2000, Excel 2002, Excel 2003, Excel 2007, Excel 2010, Outlook 2000, Outlook 2002, Outlook 2003, Outlook 2007, and Outlook 2010.
    Dim OutApp As Object
    Dim OutMail As Object
    Dim cell As Range
    Dim CS As Worksheet
   
    Set CS = Sheets("Sheet1")

    Application.ScreenUpdating = False
    Set OutApp = CreateObject("Outlook.Application")

    On Error GoTo cleanup
    For Each cell In Columns("B").Cells.SpecialCells(xlCellTypeConstants)
        If cell.Value Like "?*@?*.?*" Then
            Set OutMail = OutApp.CreateItem(0)
            On Error Resume Next
            With OutMail
                .To = "drubin@jeldwen.com"
                .CC = "drubin@jeldwen.com"
                .BCC = "drubin@jeldwen.com"
                .Subject = "ACTION REQUIRED: ENTER A BACKORDER" & CS.Range("G4").Value & "PO Number " & CS.Range("G20")
                .BodyFormat = olFormatHTML
                .HTMLBody = "Please create a backorder for the following:" & vbNewLine & vbNewLine & "Customer: " & CS.Range("G4").Value & vbNewLine & _
                    "Customer #: " & CS.Range("M4").Value & vbNewLine & "Quantity: " & CS.Range("R8").Value & vbNewLine & "PO Number: " & CS.Range("G20").Value & _
                    vbNewLine & vbNewLine & "Contact for Questions: " & CS.Range("M14").Value
                    .Display
                    '.Send  'Or use Send
            End With
            On Error GoTo 0
            Set OutMail = Nothing
        End If
    Next cell

cleanup:
    Set OutApp = Nothing
    Application.ScreenUpdating = True
   
End Sub
 
Last edited by a moderator:
Upvote 0
See if this works :

[CODE=vba]Option Explicit Sub SENDTOLOG_Click() ' '' Application.ScreenUpdating = False ' Dim CS As Worksheet, PS As Worksheet, lr As Long ' , M As Long Dim LineQuantity As Long Dim QtyRejected As Long Dim TicketLoadDate As String Dim ArSourceAddress() As Variant Dim CustName As Variant Dim POnumber As Variant Dim RejectedBy As Variant Dim SpecialBatchNumber As Variant Dim I As Long ' Set CS = Worksheets("Sheet1") Set PS = Worksheets("Sheet2") ' If CS.Range("G4") = "" Then Do CustName = Application.InputBox(Prompt:="Please enter the CUSTOMER NAME" & vbCrLf & " " & vbCrLf & "Por Favor, Introduzca el NOMBRE DEL CLIENTE") ' Text entry Loop Until CustName <> vbNullString And CustName <> False ' CS.Range("G4").Value = CustName End If ' If CS.Range("G7") = "" Then Do LineQuantity = Application.InputBox(Prompt:="Please enter the LINE QUANTITY" & vbCrLf & " " & vbCrLf & "Por Favor, introduzca la CANTIDAD DE LÍNEA", Type:=1) ' Numeric Entry Loop Until LineQuantity <> 0 And LineQuantity <> False ' CS.Range("G7").Value = LineQuantity End If ' If CS.Range("M7") = "" Then Do QtyRejected = Application.InputBox(Prompt:="Please enter the QTY REJECTED" & vbCrLf & " " & vbCrLf & "Por Favor, introduzca el QTY RECHAZADO ", Type:=1) ' Numeric Entry Loop Until QtyRejected <> 0 And QtyRejected <> False ' CS.Range("M7").Value = QtyRejected End If ' If CS.Range("G14") = "" Then Do TicketLoadDate = Application.InputBox(Prompt:="Please enter the TICKET LOAD DATE" & vbCrLf & " " & vbCrLf & "Por Favor, introduzca la FECHA DE CARGA DEL BILLETE") ' Date Entry Loop Until IsDate(TicketLoadDate) = True ' CS.Range("G14").Value = TicketLoadDate End If ' If CS.Range("M14") = "" Then Do RejectedBy = Application.InputBox(Prompt:="Please enter your name in the REJECTED BY: BOX" & vbCrLf & " " & vbCrLf & "Por Favor, introduzca su nombre en la CASILLA RECHAZADO POR") ' Text entry Loop Until RejectedBy <> vbNullString And RejectedBy <> False ' CS.Range("M14").Value = RejectedBy End If ' If CS.Range("G20") = "" Then Do POnumber = Application.InputBox(Prompt:="Please enter the PO NUMBER" & vbCrLf & " " & vbCrLf & "Por Favor, introduzca el Numero de Orden de Compra") ' Text entry Loop Until POnumber <> vbNullString And POnumber <> False ' CS.Range("G20").Value = POnumber End If ' If CS.Range("D26").Value = "CREATE SPECIAL BATCH" Then MsgBox ("YOU MUST CREATE A SPECIAL BATCH" & vbCrLf & " " & vbCrLf & "DEBE CREAR UN LOTE ESPECIAL") ' Do SpecialBatchNumber = Application.InputBox(Prompt:="ENTER THE SPECIAL BATCH TICKET NUMBER THAT WAS CREATED: " & vbCrLf & "INTRODUZCA EL NÚMERO DE TICKET DE LOTE ESPECIAL QUE SE CREÓ:") ' Text entry Loop Until SpecialBatchNumber <> vbNullString And SpecialBatchNumber <> False ' lr = PS.Range("A" & PS.Rows.Count).End(xlUp).Row + 1 ' Find First Empty Row after Data PS.Range("R" & lr).Value = SpecialBatchNumber End If ' If CS.Range("D26").Value = "DO NOT CREATE A SPECIAL BATCH AND DO NOT BACKORDER." & vbCrLf & " " & vbCrLf & "NO CREE UN LOTE ESPECIAL Y NO REALICE PEDIDOS PENDIENTES" Then MsgBox ("DO NOT CREATE A SPECIAL BATCH AND DO NOT BACKORDER. NOTHING IS REQUIRED OF YOU FOR THIS ITEM." & vbCrLf & " " & vbCrLf & "NO CREE UN LOTE ESPECIAL Y NO REALICE PEDIDOS PENDIENTES. NO SE REQUIERE NADA DE USTED PARA ESTE ARTÍCULO") End If ' If CS.Range("D26").Value = "SEND TO OFFICE TO CREATE A BACKORDER." & vbCrLf & " " & vbCrLf & "ENVIAR A OFICINA PARA CREAR UN PEDIDO PENDIENTE" Then Call Email ' lr = PS.Range("A" & PS.Rows.Count).End(xlUp).Row + 1 ' Find First Empty Row after Data ' End If ' lr = PS.Cells(Rows.Count, 1).End(xlUp).Row + 1 ' Find First Empty Row after Data ' ' Copy data from the INPUT to the RECORDS worksheet ArSourceAddress = Array("M4", "G4", "D17", "G14", "G7", "M7", "P7", "G11", "D26", "M14", "G20") ' For I = 0 To UBound(ArSourceAddress) PS.Cells(lr, I + 1).Value = CS.Range(ArSourceAddress(I)).Value ' Columns 1 thru 11 .... Array addresses Next ' PS.Cells(lr, 12).Resize(, 4).Value = CS.Range("S24").Resize(, 4).Value 'Columns 12,13,14,15 .... S24,T24,U24,V24 ' PS.Cells(lr, 16).Resize(, 2).Value = CS.Range("X24").Resize(, 2).Value ' Columns 15,16 .... X24,Y24 ' MsgBox "THE RECORD HAS BEEN SAVED." & vbCrLf & " " & vbCrLf & "EL REGISTRO SE HA GUARDADO." Call Email ''Application.ScreenUpdating = True End Sub Sub Email() ' Works in Excel 2000, Excel 2002, Excel 2003, Excel 2007, Excel 2010, Outlook 2000, Outlook 2002, Outlook 2003, Outlook 2007, and Outlook 2010. Dim OutApp As Object Dim OutMail As Object Dim cell As Range Dim CS As Worksheet Set CS = Sheets("Sheet1") Application.ScreenUpdating = False Set OutApp = CreateObject("Outlook.Application") On Error GoTo cleanup For Each cell In Columns("B").Cells.SpecialCells(xlCellTypeConstants) If cell.Value Like "?*@?*.?*" Then Set OutMail = OutApp.CreateItem(0) On Error Resume Next With OutMail .To = "drubin@jeldwen.com" .CC = "drubin@jeldwen.com" .BCC = "drubin@jeldwen.com" .Subject = "ACTION REQUIRED: ENTER A BACKORDER" & CS.Range("G4").Value & "PO Number " & CS.Range("G20") .BodyFormat = olFormatHTML .HTMLBody = "Please create a backorder for the following:" & vbNewLine & vbNewLine & "Customer: " & CS.Range("G4").Value & vbNewLine & _ "Customer #: " & CS.Range("M4").Value & vbNewLine & "Quantity: " & CS.Range("R8").Value & vbNewLine & "PO Number: " & CS.Range("G20").Value & _ vbNewLine & vbNewLine & "Contact for Questions: " & CS.Range("M14").Value .Display '.Send 'Or use Send End With On Error GoTo 0 Set OutMail = Nothing End If Next cell cleanup: Set OutApp = Nothing Application.ScreenUpdating = True End Sub [/CODE]
It says "subscript out of range" I tried changing "Sheet1" to "Input".
 
Upvote 0
VBA Code:
Option Explicit

Sub SENDTOLOG_Click()
'
''    Application.ScreenUpdating = False
'
Dim CS As Worksheet, PS As Worksheet, lr As Long        ' , M As Long
    Dim LineQuantity        As Long
    Dim QtyRejected         As Long
    Dim TicketLoadDate      As String
    Dim ArSourceAddress()   As Variant
    Dim CustName            As Variant
    Dim POnumber            As Variant
    Dim RejectedBy          As Variant
    Dim SpecialBatchNumber  As Variant
    Dim I As Long
'
    [B][COLOR=rgb(209, 72, 65)]Set CS = Worksheets("Input")
    Set PS = Worksheets("Records")[/COLOR][/B]
'
    If CS.Range("G4") = "" Then
        Do
            CustName = Application.InputBox(Prompt:="Please enter the CUSTOMER NAME" & vbCrLf & " " & vbCrLf & "Por Favor, Introduzca el NOMBRE DEL CLIENTE")  ' Text entry
        Loop Until CustName <> vbNullString And CustName <> False
'
        CS.Range("G4").Value = CustName
    End If
'
    If CS.Range("G7") = "" Then
        Do
            LineQuantity = Application.InputBox(Prompt:="Please enter the LINE QUANTITY" & vbCrLf & " " & vbCrLf & "Por Favor, introduzca la CANTIDAD DE LÍNEA", Type:=1)  ' Numeric Entry
        Loop Until LineQuantity <> 0 And LineQuantity <> False
'
        CS.Range("G7").Value = LineQuantity
    End If
'
    If CS.Range("M7") = "" Then
        Do
            QtyRejected = Application.InputBox(Prompt:="Please enter the QTY REJECTED" & vbCrLf & " " & vbCrLf & "Por Favor, introduzca el QTY RECHAZADO   ", Type:=1)    ' Numeric Entry
        Loop Until QtyRejected <> 0 And QtyRejected <> False
'
        CS.Range("M7").Value = QtyRejected
    End If
'
    If CS.Range("G14") = "" Then
        Do
            TicketLoadDate = Application.InputBox(Prompt:="Please enter the TICKET LOAD DATE" & vbCrLf & " " & vbCrLf & "Por Favor, introduzca la FECHA DE CARGA DEL BILLETE")      ' Date Entry
        Loop Until IsDate(TicketLoadDate) = True
'
        CS.Range("G14").Value = TicketLoadDate
    End If
'
    If CS.Range("M14") = "" Then
        Do
            RejectedBy = Application.InputBox(Prompt:="Please enter your name in the REJECTED BY: BOX" & vbCrLf & " " & vbCrLf & "Por Favor, introduzca su nombre en la CASILLA RECHAZADO POR") ' Text entry
        Loop Until RejectedBy <> vbNullString And RejectedBy <> False
'
        CS.Range("M14").Value = RejectedBy
    End If
'
    If CS.Range("G20") = "" Then
        Do
            POnumber = Application.InputBox(Prompt:="Please enter the PO NUMBER" & vbCrLf & " " & vbCrLf & "Por Favor, introduzca el Numero de Orden de Compra")  ' Text entry
        Loop Until POnumber <> vbNullString And POnumber <> False
'
        CS.Range("G20").Value = POnumber
    End If
'
    If CS.Range("D26").Value = "CREATE SPECIAL BATCH" Then
        MsgBox ("YOU MUST CREATE A SPECIAL BATCH" & vbCrLf & " " & vbCrLf & "DEBE CREAR UN LOTE ESPECIAL")
'
        Do
            SpecialBatchNumber = Application.InputBox(Prompt:="ENTER THE SPECIAL BATCH TICKET NUMBER THAT WAS CREATED: " & vbCrLf & "INTRODUZCA EL NÚMERO DE TICKET DE LOTE ESPECIAL QUE SE CREÓ:") ' Text entry
        Loop Until SpecialBatchNumber <> vbNullString And SpecialBatchNumber <> False
'
        lr = PS.Range("A" & PS.Rows.Count).End(xlUp).Row + 1            ' Find First Empty Row after Data

        PS.Range("R" & lr).Value = SpecialBatchNumber
    End If
'
    If CS.Range("D26").Value = "DO NOT CREATE A SPECIAL BATCH AND DO NOT BACKORDER." & vbCrLf & " " & vbCrLf & "NO CREE UN LOTE ESPECIAL Y NO REALICE PEDIDOS PENDIENTES" Then
        MsgBox ("DO NOT CREATE A SPECIAL BATCH AND DO NOT BACKORDER. NOTHING IS REQUIRED OF YOU FOR THIS ITEM." & vbCrLf & " " & vbCrLf & "NO CREE UN LOTE ESPECIAL Y NO REALICE PEDIDOS PENDIENTES. NO SE REQUIERE NADA DE USTED PARA ESTE ARTÍCULO")
    End If
'
    If CS.Range("D26").Value = "SEND TO OFFICE TO CREATE A BACKORDER." & vbCrLf & " " & vbCrLf & "ENVIAR A OFICINA PARA CREAR UN PEDIDO PENDIENTE" Then
  
    Call Email
'
        lr = PS.Range("A" & PS.Rows.Count).End(xlUp).Row + 1            ' Find First Empty Row after Data
'
End If
'
    lr = PS.Cells(Rows.Count, 1).End(xlUp).Row + 1                  ' Find First Empty Row after Data
'
'   Copy data from the INPUT to the RECORDS worksheet
    ArSourceAddress = Array("M4", "G4", "D17", "G14", "G7", "M7", "P7", "G11", "D26", "M14", "G20")
'
    For I = 0 To UBound(ArSourceAddress)
        PS.Cells(lr, I + 1).Value = CS.Range(ArSourceAddress(I)).Value           ' Columns 1 thru 11 .... Array addresses
    Next
'
    PS.Cells(lr, 12).Resize(, 4).Value = CS.Range("S24").Resize(, 4).Value  'Columns 12,13,14,15 .... S24,T24,U24,V24
'
    PS.Cells(lr, 16).Resize(, 2).Value = CS.Range("X24").Resize(, 2).Value  ' Columns 15,16 .... X24,Y24
'
    MsgBox "THE RECORD HAS BEEN SAVED." & vbCrLf & " " & vbCrLf & "EL REGISTRO SE HA GUARDADO."
  
    Call Email

''Application.ScreenUpdating = True

End Sub

Sub Email()


' Works in Excel 2000, Excel 2002, Excel 2003, Excel 2007, Excel 2010, Outlook 2000, Outlook 2002, Outlook 2003, Outlook 2007, and Outlook 2010.
    Dim OutApp As Object
    Dim OutMail As Object
    Dim cell As Range
    Dim CS As Worksheet
  
    Set CS = Sheets("Sheet1")

    Application.ScreenUpdating = False
    Set OutApp = CreateObject("Outlook.Application")

    On Error GoTo cleanup
    For Each cell In Columns("B").Cells.SpecialCells(xlCellTypeConstants)
        If cell.Value Like "?*@?*.?*" Then
            Set OutMail = OutApp.CreateItem(0)
            On Error Resume Next
            With OutMail
                .To = "drubin@jeldwen.com"
                .CC = "drubin@jeldwen.com"
                .BCC = "drubin@jeldwen.com"
                .Subject = "ACTION REQUIRED: ENTER A BACKORDER" & CS.Range("G4").Value & "PO Number " & CS.Range("G20")
                .BodyFormat = olFormatHTML
                .HTMLBody = "Please create a backorder for the following:" & vbNewLine & vbNewLine & "Customer: " & CS.Range("G4").Value & vbNewLine & _
                    "Customer #: " & CS.Range("M4").Value & vbNewLine & "Quantity: " & CS.Range("R8").Value & vbNewLine & "PO Number: " & CS.Range("G20").Value & _
                    vbNewLine & vbNewLine & "Contact for Questions: " & CS.Range("M14").Value
                    .Display
                    '.Send  'Or use Send
            End With
            On Error GoTo 0
            Set OutMail = Nothing
        End If
    Next cell

cleanup:
    Set OutApp = Nothing
    Application.ScreenUpdating = True
  
End Sub
 
Upvote 0

Forum statistics

Threads
1,215,066
Messages
6,122,948
Members
449,095
Latest member
nmaske

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top