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 |
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