ExcelBanter

ExcelBanter (https://www.excelbanter.com/)
-   Excel Programming (https://www.excelbanter.com/excel-programming/)
-   -   Email: Establishing Primary Cell vs. Ranges & Matches (https://www.excelbanter.com/excel-programming/454153-email-establishing-primary-cell-vs-ranges-matches.html)

Living the Dream

Email: Establishing Primary Cell vs. Ranges & Matches
 
Hi Claus

I did a revision of my original code which make it easier for you to understand my end goal.

So, the user will select a Cell in Column D of PF-Log, then hit the "Send Email". The code is meant to collect all the strings that will populate the email body.

The problem with the following is it throws an error he Dim myCell As Range: Set myCell = ActiveCell


Sub sendEmails()

Dim sWB As Workbook: Set sWB = ThisWorkbook
Dim sLog As Worksheet: Set sLog = sWB.Sheets("PF-Log")
Dim sHist As Worksheet: Set sHist = sWB.Sheets("Historical")
Dim sSup As Worksheet: Set sSup = sWB.Sheets("Support")

Dim myContact As Range: Set myContact = sSup.Range("D2:D100")
Dim myLoadID As Range: Set myLoadID = sHist.Range("B2:B30000")
Dim myCell As Range: Set myCell = ActiveCell

Dim EmailTo As String, EmailCC As String
Dim Who As String, When As String, Load As String
Dim Flow As String, Issue As String, Comment As String, Outcome As String
Dim iLoad As String, iPO As String, iVend As String, kSub As String, kDC As String
Dim iWoods As String, iSpaces As String, iWeight As String, iTime As String

Dim rngSource1 As Range, rngTarget1 As Range, rng1 As Range
Dim lLastRow1 As Long, LRow1 As Long

Dim rngSource2 As Range, rngTarget2 As Range, rng2 As Range
Dim lLastRow2 As Long, LRow2 As Long

Set rngTarget1 = Sheets("Support").Range("$D$2:$A$100")
Set rngSource1 = Sheets("PF-Log").myCell

lLastRow1 = rngSource1.Rows(rngSource1.Rows.Count).End(xlUp).R ow

For LRow1 = 2 To lLastRow1
Set rng1 = rngTarget1.Find(what:=rngSource1.Cells(LRow), LookAt:=xlWhole)
If Not rng1 Is Nothing Then
EmailTo = rng1.Offset(, 1).Value
EmailCC = rng1.Offset(, 2).Value
End If
Next LRow1

Who = myCell.Value
When = myCell.Offset(, -3).Value
Load = myCell.Offset(, -2).Value
Flow = myCell.Offset(, -1).Value
Issue = myCell.Offset(, 1).Value
Comment = myCell.Offset(, 2).Value
Outcome = myCell.Offset(, 3).Value

Set rngTarget2 = Sheets("Historical").Range("$B$2:$B$30000")
Set rngSource2 = Sheets("PF-Log").myCell.Offset(, -2)

lLastRow2 = rngSource2.Rows(rngSource2.Rows.Count).End(xlUp).R ow

For LRow2 = 2 To lLastRow2
Set rng2 = rngTarget2.Find(what:=rngSource2.Cells(LRow), LookAt:=xlWhole)
If Not rng2 Is Nothing Then
iLoad = rng2.Value
iPO = rng2.Offset(, 1).Value
iVend = rng2.Offset(, 3).Value
iSub = rng2.Offset(, 4).Value
iDC = rng2.Offset(, 5).Value
iWoods = rng2.Offset(, 8).Value
iSpaces = rng2.Offset(, 6).Value
iWeight = rng2.Offset(, 7).Value
iTime = rng2.Offset(, 12).Value
End If
Next LRow2

TIA
Mark

Claus Busch

Email: Establishing Primary Cell vs. Ranges & Matches
 
Hi Mark,

Am Tue, 28 Aug 2018 17:58:05 -0700 (PDT) schrieb Living the Dream:

I did a revision of my original code which make it easier for you to understand my end goal.

So, the user will select a Cell in Column D of PF-Log, then hit the "Send Email". The code is meant to collect all the strings that will populate the email body.

The problem with the following is it throws an error he Dim myCell As Range: Set myCell = ActiveCell


< code snipped

Try:

Sub Mail()
Dim Who As String, When As String, LoadID As String, Flow As String, Issue As String, Comment As String, Outcome As String
Dim EmailTo As String, EmailCC As String, strBody As String
Dim iLoad As String, iPO As String, iVend As String, iSub As String, iDC As String, iWoods As String, iSpaces As String, iWeight As String, iTime As String
Dim LRow As Long
Dim c As Range
Dim OutApp As Object, OutMail As Object

Set OutApp = GetObject(, "Outlook.Application")
If OutApp Is Nothing Then Set OutApp =
CreateObject("Outlook.Application")
Set OutMail = OutApp.createitem(0)

With ActiveCell
Who = .Value
When = .Offset(, -3).Value
LoadID = .Offset(, -2).Value
Flow = .Offset(, -1).Value
Issue = .Offset(, 1).Value
Comment = .Offset(, 2).Value
Outcome = .Offset(, 3).Value
End With

With Sheets("Support")
Set c = .Range("D:D").Find(Who, LookIn:=xlValues, lookat:=xlWhole)
If Not c Is Nothing Then
EmailTo = .Cells(c.Row, "E")
EmailCC = .Cells(c.Row, "F")
End If
End With

With Sheets("Historical")
LRow = .Cells(Rows.Count, "A").End(xlUp).Row
Set c = .Range("B1:B" & LRow).Find(LoadID, LookIn:=xlValues,
lookat:=xlWhole)
If Not c Is Nothing Then
iLoad = c.Value
iPO = c.Offset(, 1).Value
iVend = c.Offset(, 3).Value
iSub = c.Offset(, 4).Value
iDC = c.Offset(, 5).Value
iWoods = c.Offset(, 8).Value
iSpaces = c.Offset(, 6).Value
iWeight = c.Offset(, 7).Value
iTime = c.Offset(, 12).Value
End If
End With

With Application
strBody = "Hi " & Who & .Rept(Chr(10), 2) & _
"As per our discussion regarding the following:" & .Rept(Chr(10), 2) & _
"Log Flow:" & .Rept(Chr(32), 15) & Flow & " - Log Date/Time: "
& When & .Rept(Chr(10), 2) & _
"Issue:" & .Rept(Chr(32), 22) & Issue & .Rept(Chr(10), 2) & _
"Comment:" & .Rept(Chr(32), 14) & Comment & .Rept(Chr(10), 2) & _
"Vendor:" & .Rept(Chr(32), 18) & iVend & Chr(10) & _
"Load ID:" & .Rept(Chr(32), 18) & iLoad & Chr(10) & _
"PO No(s):" & .Rept(Chr(32), 16) & iPO & Chr(10) & _
"Pallet(s):" & .Rept(Chr(32), 17) & iWoods & Chr(10) & _
"Space(s):" & .Rept(Chr(32), 17) & iSpaces & Chr(10) & _
"Weight:" & .Rept(Chr(32), 19) & iWeight & .Rept(Chr(10), 2) & _
"Collection Time:" & .Rept(Chr(32), 5) & iTime & .Rept(Chr(10), 2) & _
"Bound For:" & .Rept(Chr(32), 14) & iDC & .Rept(Chr(10), 2) & _
"Outcome:" & .Rept(Chr(32), 16) & Outcome
End With

With OutMail
.To = EmailTo
.CC = EmailCC
.Subject = iVend & " - " & iLoad
.Body = strBody
.Display '.send now throws up Security Marning so DO NOT USE.
End With
End Sub


Regards
Claus B.
--
Windows10
Office 2016


All times are GMT +1. The time now is 03:03 PM.

Powered by vBulletin® Copyright ©2000 - 2024, Jelsoft Enterprises Ltd.
ExcelBanter.com