Patriot2879
Well-known Member
- Joined
- Feb 1, 2018
- Messages
- 1,259
- Office Version
- 2010
- Platform
- Windows
Hiya good morning, i have 2 codes below that do the same sort of thing, where one adds a message if a 'name cant be found' and asks if i want to continue or not, and the other code adds a border when an email is sent. I would like the 'name cant be found bit added to the other code where the border is implemented. Hope you can help with my query please see the 2 codes below.
Below is code with name cannot be found msg box -
Below is the code with the border and where i want the coding for 'name cannot be found' added to with msg box.
Below is code with name cannot be found msg box -
VBA Code:
Private Sub CommandButton1_Click()
Application.ScreenUpdating = False
Dim OutApp As Object, OutMail As Object, rng As Range, v As Variant, i As Long, lRow As Long, rName As Range
lRow = Cells(Rows.Count, "A").End(xlUp).Row
With Sheets("Sheet1").Sort
.SortFields.Clear
.SortFields.Add Key:=Range("A2:A" & lRow), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
.SortFields.Add Key:=Range("E2:E" & lRow), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
.SortFields.Add Key:=Range("F2:F" & lRow), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
.SetRange Range("A1:J" & lRow)
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
v = Range("A2:A" & lRow).Resize(, 11).Value
Set OutApp = CreateObject("Outlook.Application")
With CreateObject("scripting.dictionary")
For i = LBound(v) To UBound(v)
If v(i, 11) <> "yes" Then
Set rName = Sheets("Email Links").Range("A:A").Find(v(i, 1), LookIn:=xlValues, lookat:=xlWhole)
If Not rName Is Nothing Then
If Not .exists(v(i, 1)) Then
.Add v(i, 1), Nothing
Range("A1").CurrentRegion.AutoFilter 1, v(i, 1)
Set rng = Range("A1:G" & lRow).SpecialCells(xlCellTypeVisible)
Set OutMail = OutApp.CreateItem(0)
With OutMail
.To = rName.Offset(, 21)
.cc = rName.Offset(, 22)
.Subject = "Weekly Work Issue" & "-" & v(i, 5) & "-" & v(i, 1)
.HTMLBody = "<p>Hi " & v(i, 1) & "," & "<br><br>" & "Please see below an overview of your work Tuesday to Friday. Your final schedule will be emailed to you the day before the appointments are due to take place." & "<br><br>" & v(i, 10) & "<br>" & RangetoHTML(rng)
.Display
End With
End If
Else
If MsgBox(v(i, 1) & " was not found. Do you wish to continue?", vbYesNo) = vbNo Then
Range("A1").AutoFilter
Exit Sub
End If
End If
End If
Next i
End With
Range("A1").AutoFilter
Application.ScreenUpdating = True
End SubBelow is the code with the border and where i want the coding for 'name cannot be found' added to with msg box.
Code:
Private Sub CommandButton1_Click()
ActiveWorkbook.Worksheets("Sheet1").AutoFilter.Sort.SortFields.Clear
ActiveWorkbook.Worksheets("Sheet1").AutoFilter.Sort.SortFields.Add2 Key:= _
Range("A2", Range("A" & Rows.Count).End(xlUp)), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption _
:=xlSortNormal
ActiveWorkbook.Worksheets("Sheet1").AutoFilter.Sort.SortFields.Add2 Key:= _
Range("E2", Range("E" & Rows.Count).End(xlUp)), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption _
:=xlSortNormal
ActiveWorkbook.Worksheets("Sheet1").AutoFilter.Sort.SortFields.Add2 Key:= _
Range("F2", Range("F" & Rows.Count).End(xlUp)), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption _
:=xlSortNormal
With ActiveWorkbook.Worksheets("Sheet1").AutoFilter.Sort
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
Columns("A:G").Select
With Selection
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ReadingOrder = xlContext
.MergeCells = False
End With
With Selection
.WrapText = True
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ReadingOrder = xlContext
.MergeCells = False
End With
Dim answer As Integer
answer = MsgBox("Do you want to continue?", vbQuestion + vbYesNo)
If answer = vbNo Then Exit Sub
'Some Code
Dim Cl As Range
For Each Cl In Range("A2", Range("A" & Rows.Count).End(xlUp))
Cl.Value = Trim(Cl.Value)
Next Cl
Dim lr As Long
lr = Cells(Rows.Count, "A").End(xlUp).Row
With Range("I2:I" & lr)
.Formula = "=XLOOKUP(A2,'Email Links'!A:A,'Email Links'!V:V)"
.Value = .Value
End With
lr = Cells(Rows.Count, "A").End(xlUp).Row
With Range("H2:H" & lr)
.Formula = "=XLOOKUP(A2,'Email Links'!A:A,'Email Links'!W:W)"
.Value = .Value
End With
lr = Cells(Rows.Count, "A").End(xlUp).Row
With Range("J2:J" & lr)
.Formula = "=XLOOKUP(A2,'Email Links'!A:A,'Email Links'!Y:Y)"
.Value = .Value
End With
'Set email address as range for first loop to run down
Set Rng = Range(Range("I2"), Range("I" & Rows.Count).End(xlUp))
'Get a row count to clear column H at the end
x = Rng.Rows.Count
PgStart = "<html><body>"
'Create the html table and header from the first row
tableHdr = "<table border=1><tr><th>" & Range("A1").Value & "</th>" _
& "<th>" & Range("B1").Value & "</th>" _
& "<th>" & Range("C1").Value & "</th>" _
& "<th>" & Range("D1").Value & "</th>" _
& "<th>" & Range("E1").Value & "</th>" _
& "<th>" & Range("F1").Value & "</th>" _
& "<th>" & Range("G1").Value & "</th>" _
'& "<th>" & Range("H1").Value & "</th>" _
'& "<th>" & Range("I1").Value & "</th>" _
'Check to see if column G = 'yes' and skip mail if it does
For Each cell In Rng
If cell.Value <> "" Then
If Not cell.Offset(0, 2).Value = "yes" Then
NmeRow = cell.Row
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.createitem(0)
MailTo = cell.Value 'column E
mailcc = cell.Offset(0, -1).Value
MailSubject = "Weekly Work Issue" & "-" & cell.Offset(0, -4).Value & "-" & cell.Offset(0, -8).Value
'Create MailBody table row for first row
MailBody = "<tr>" _
& "<td>" & cell.Offset(0, -8).Value & "</td>" _
& "<td>" & cell.Offset(0, -7).Value & "</td>" _
& "<td>" & cell.Offset(0, -6).Value & "</td>" _
& "<td>" & cell.Offset(0, -5).Value & "</td>" _
& "<td>" & cell.Offset(0, -4).Value & "</td>" _
& "<td>" & cell.Offset(0, -3).Value & "</td>" _
& "<td>" & cell.Offset(0, -2).Value & "</td>" _
& "</tr>"
'Second loop checks the email addresses of all cells following the current cell in the first loop.
'Yes will be appended on any duplicate finds and another row added to the mailbody table
For Each dwn In Rng.Offset(NmeRow - 1, 0)
If dwn.Value = cell.Value Then
'Create additional table row for each extra row found
AddRow = "<tr>" _
& "<td>" & dwn.Offset(0, -8).Value & "</td>" _
& "<td>" & dwn.Offset(0, -7).Value & "</td>" _
& "<td>" & dwn.Offset(0, -6).Value & "</td>" _
& "<td>" & dwn.Offset(0, -5).Value & "</td>" _
& "<td>" & dwn.Offset(0, -4).Value & "</td>" _
& "<td>" & dwn.Offset(0, -3).Value & "</td>" _
& "<td>" & dwn.Offset(0, -2).Value & "</td>" _
& "</tr>"
dwn.Offset(0, 2).Value = "yes"
MailBody = MailBody & AddRow 'column A
End If
' Clear additional table row variable ready for next
AddRow = ""
Next
MsgStr = "<p>Hi " & cell.Offset(0, -8).Value & "," & vbNewLine & "please see below an overview of your work Tuesday to Friday. Your final schedule will be emailed to you the day before the appointments are due to take place." & "<br><br>" & vbNewLine & cell.Offset(0, 1).Value & "<br><br>" _
With OutMail
.To = MailTo
.CC = mailcc
.Subject = MailSubject
.HTMLBody = PgStart & MsgStr & tableHdr & MailBody & "</table></body></html>" & "<br><br>" & vbNewLine & "Any issues, please contact your FTL." & "<br><br>" & vbNewLine & "Many Thanks" & "<br><br>" & vbNewLine & "Complex Team"
.Send
'send
End With
cell.Offset(0, 2).Value = "yes"
End If
End If
MailTo = ""
MailSubject = ""
MailBody = ""
Next
'Clear 'yes' from all appended cells in column H
Range("K2:K" & x + 1).ClearContents
End Sub
