If name not found msgbox states the name which is not found

P

Patriot2879

Well-known Member
Joined
Feb 1, 2018
Messages
1,231
Office Version
  1. 2010
Platform
  1. Windows
Hi All happy Friday, I hope you can help me please - i have a snippet of code below where the Range is A2 to last row and under 'Email Links row V to find the matching name. This works great, but i would like to add a message box that if the name is not found in A2 to last row then a message box will pop up stating 'Jo Bloggs' not found! - for example, then asks a yes or no if i want to continue and it will skip that name not found. Can you help please and i hope this makes sense.
VBA 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
 
Sort by date Sort by votes
mumps said:
Could you use code tags to post your original code and explain in detail what else you want the macro to do referring to specific cells, rows, columns and sheets,
Click to expand...
Hi good evening thank you for your help, please see below my original code. Hope it all makes sense and can manage to add the part you created into this please :)

This section below is where i get all the data filtered and sorted first -

VBA 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
This part is where a message box pops up asking if you want to continue.
Code: 
Dim answer As Integer
  answer = MsgBox("Do you want to continue?", vbQuestion + vbYesNo)

  If answer = vbNo Then Exit Sub
This part is looking at the range A2 to last row
Code: 
   Dim Cl As Range
   For Each Cl In Range("A2", Range("A" & Rows.Count).End(xlUp))
      Cl.Value = Trim(Cl.Value)
   Next Cl
This part is doing a lookup in email links sheet for A:A to W:W and Y:Y
Code: 
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
This part below is to set email address as range for first loop to run down
Code: 
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>"
This part below is to create the html table and header from the first row
Code: 
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>" _

This part below is to check to see if column G = 'yes' and skip mail if it does
Code: 
For Each cell In Rng
If cell.Value <> "" Then
    If Not cell.Offset(0, 2).Value = "yes" Then

      
    NmeRow = cell.Row
This part below is for the email and subject
Code: 
    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
This part below is to Create MailBody table row for first row
Code: 
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
Code: 
For Each dwn In Rng.Offset(NmeRow - 1, 0)



    If dwn.Value = cell.Value Then
Create additional table row for each extra row found
Code: 
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
 
Upvote 0

Excel Facts

Convert text numbers to real numbers
Select a column containing text numbers. Press Alt+D E F to quickly convert text to numbers. Faster than "Convert to Number"
Thank you for the code. It helps but it is hard to follow without having references to the actual data. Much of it is not necessary because the macro I suggested takes care of it. For example, the data doesn't need to be filtered and sorted unless there is another reason why you want it that way. If the file you uploaded is not your actual file, please upload a copy of the actual file (de-sensitized if necessary). Rather than general comments such as "'Yes will be appended on any duplicate finds and another row added to the mailbody table", I need a detailed explanation of what you want to do referring to specific cells, rows, columns and sheets using a few examples from your data. I would need this for any task that you want done that is not included in the macro I suggested.
 
Upvote 0
mumps said:
Thank you for the code. It helps but it is hard to follow without having references to the actual data. Much of it is not necessary because the macro I suggested takes care of it. For example, the data doesn't need to be filtered and sorted unless there is another reason why you want it that way. If the file you uploaded is not your actual file, please upload a copy of the actual file (de-sensitized if necessary). Rather than general comments such as "'Yes will be appended on any duplicate finds and another row added to the mailbody table", I need a detailed explanation of what you want to do referring to specific cells, rows, columns and sheets using a few examples from your data. I would need this for any task that you want done that is not included in the macro I suggested.
Click to expand...
Hi good morning thank you, the file I put on drop box is the actual file I have only changed the names and email addresses, hope that helps. I need it filtered because it puts the dates, time bands and names in order for me which I need .
 
Upvote 0
In this part of your code:
VBA Code: 
For Each cell In rng
    If cell.Value <> "" Then
        If Not cell.Offset(0, 2).Value = "yes" Then
the variable rng refers to column I which means that cell.Offset(0, 2).Value refers to column K. However, column K is blank. Please clarify in detail.
 
Upvote 0
mumps said:
In this part of your code:
VBA Code: 
For Each cell In rng
    If cell.Value <> "" Then
        If Not cell.Offset(0, 2).Value = "yes" Then
the variable rng refers to column I which means that cell.Offset(0, 2).Value refers to column K. However, column K is blank. Please clarify in detail.
Click to expand...
Hi there once it sends an email it inputs yes into the cell and then clears the cell once all the emails are sent
 
Upvote 0
VBA Code: 
MailSubject = "Weekly Work Issue" & "-" & cell.Offset(0, -4).Value & "-" & cell.Offset(0, -8).Value
What value is in the two 'offset' cells?
 
Upvote 0
mumps said:
VBA Code: 
MailSubject = "Weekly Work Issue" & "-" & cell.Offset(0, -4).Value & "-" & cell.Offset(0, -8).Value
What value is in the two 'offset' cells?
Click to expand...
Sorry I don’t understand what you mean
 
Upvote 0
What data is found in those two cells?
 
Upvote 0
Try:
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 Sub

Function RangetoHTML(rng As Range)
    Dim fso As Object
    Dim ts As Object
    Dim TempFile As String
    Dim TempWB As Workbook
    TempFile = Environ$("temp") & "\" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"
    rng.Copy
    Set TempWB = Workbooks.Add(1)
    With TempWB.Sheets(1)
        .Cells(1).PasteSpecial Paste:=8
        .Cells(1).PasteSpecial xlPasteValues, , False, False
        .Cells(1).PasteSpecial xlPasteFormats, , False, False
        .Cells(1).Select
        Application.CutCopyMode = False
        On Error Resume Next
        .DrawingObjects.Visible = True
        .DrawingObjects.Delete
        On Error GoTo 0
    End With
    With TempWB.PublishObjects.Add( _
         SourceType:=xlSourceRange, _
         Filename:=TempFile, _
         Sheet:=TempWB.Sheets(1).Name, _
         Source:=TempWB.Sheets(1).UsedRange.Address, _
         HtmlType:=xlHtmlStatic)
        .Publish (True)
    End With
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set ts = fso.GetFile(TempFile).OpenAsTextStream(1, -2)
    RangetoHTML = ts.readall
    ts.Close
    RangetoHTML = Replace(RangetoHTML, "align=center x:publishsource=", "align=left x:publishsource=")
    TempWB.Close savechanges:=False
    Kill TempFile
    Set ts = Nothing
    Set fso = Nothing
    Set TempWB = Nothing
End Function
 
Upvote 0
You must log in or register to reply here.

Similar threads

B
  • Question
Excel 365 Compare Date & Copy Cell Data for Data Base
2 3 4
Replies
33
Views
851
skillilea
S
JohnPoole
  • Solved
Delete rows based on unique values
2
Replies
17
Views
934
kevin9999
K
J
  • Solved
VBA to compare rows in two different sheets, if match highlight cell
2
Replies
10
Views
727
kevin9999
K
N
  • Solved
Move entire row based on expiration date
2
Replies
17
Views
345
rollis13
rollis13
H
  • Solved
Macro to display message end of Code where Col D contains blanks
Replies
7
Views
357
howard
H

Forum statistics

Threads
1,215,772
Messages
6,126,814
Members
449,339
Latest member
Cap N

Share this page

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