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

P

Patriot2879

Well-known Member
Joined
Feb 1, 2018
Messages
1,227
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

Excel Facts

How can you turn a range sideways?
Copy the range. Select a blank cell. Right-click, Paste Special, then choose Transpose.
Are there two different email addresses, one in column U and the other in column V? If so, which one do you want to use? In the file you posted, the email addresses are in columns V and W. Column U is blank. Maybe you could upload a revised file with the actual data (de-sensitized if necessary).
 
Upvote 0
mumps said:
Are there two different email addresses, one in column U and the other in column V? If so, which one do you want to use? In the file you posted, the email addresses are in columns V and W. Column U is blank. Maybe you could upload a revised file with the actual data (de-sensitized if necessary).
Click to expand...
Sorry yes columns v and w. W is the cc email
 
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.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    v = Range("A2:A" & lRow).Value
    Set OutApp = CreateObject("Outlook.Application")
    With CreateObject("scripting.dictionary")
        For i = LBound(v) To UBound(v)
            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)
                    'fVisRow = Rows("2:" & lRow).SpecialCells(xlCellTypeVisible).Row
                    Set rng = Range("A2:G" & lRow).SpecialCells(xlCellTypeVisible)
                    Set OutMail = OutApp.CreateItem(0)
                    With OutMail
                        .To = rName.Offset(, 21)
                        .cc = rName.Offset(, 22)
                        .Subject = ""
                        .HTMLBody = RangetoHTML(rng)
                        .Display
                    End With
                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
mumps said:
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.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    v = Range("A2:A" & lRow).Value
    Set OutApp = CreateObject("Outlook.Application")
    With CreateObject("scripting.dictionary")
        For i = LBound(v) To UBound(v)
            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)
                    'fVisRow = Rows("2:" & lRow).SpecialCells(xlCellTypeVisible).Row
                    Set rng = Range("A2:G" & lRow).SpecialCells(xlCellTypeVisible)
                    Set OutMail = OutApp.CreateItem(0)
                    With OutMail
                        .To = rName.Offset(, 21)
                        .cc = rName.Offset(, 22)
                        .Subject = ""
                        .HTMLBody = RangetoHTML(rng)
                        .Display
                    End With
                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
Click to expand...
Hi good morning thank yhou for the code much appreciated, it sort of does what i want, but is there any way of having a message box pop up to highlight which names werent found?
 
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
    v = Range("A2:A" & lRow).Value
    Set OutApp = CreateObject("Outlook.Application")
    With CreateObject("scripting.dictionary")
        For i = LBound(v) To UBound(v)
            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("A2:G" & lRow).SpecialCells(xlCellTypeVisible)
                    Set OutMail = OutApp.CreateItem(0)
                    With OutMail
                        .To = rName.Offset(, 21)
                        .cc = rName.Offset(, 22)
                        .Subject = ""
                        .HTMLBody = RangetoHTML(rng)
                        .Display
                    End With
                End If
            Else
                MsgBox (rName & " was not found.")
            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
mumps said:
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
    v = Range("A2:A" & lRow).Value
    Set OutApp = CreateObject("Outlook.Application")
    With CreateObject("scripting.dictionary")
        For i = LBound(v) To UBound(v)
            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("A2:G" & lRow).SpecialCells(xlCellTypeVisible)
                    Set OutMail = OutApp.CreateItem(0)
                    With OutMail
                        .To = rName.Offset(, 21)
                        .cc = rName.Offset(, 22)
                        .Subject = ""
                        .HTMLBody = RangetoHTML(rng)
                        .Display
                    End With
                End If
            Else
                MsgBox (rName & " was not found.")
            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
Click to expand...
Hi thanks for this i run the code but it just sent the one email to Joanne Bloggs i didnt get a msgbox pop up, and i got the error 'Run-time error 91 object variable or with block variable not set'.
 
Upvote 0
I'm having trouble accessing the cells in your worksheets. It appears that they are locked but the sheets are not protected so I can't figure out what's going on. Can you check the sheets in your file and make sure that all the cells are accessible and upload another copy?
 
Upvote 0
This code is working properly for me in the last file you uploaded:
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
    v = Range("A2:A" & lRow).Value
    Set OutApp = CreateObject("Outlook.Application")
    With CreateObject("scripting.dictionary")
        For i = LBound(v) To UBound(v)
            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)
                    'fVisRow = Rows("2:" & lRow).SpecialCells(xlCellTypeVisible).Row
                    Set rng = Range("A2:G" & lRow).SpecialCells(xlCellTypeVisible)
                    Set OutMail = OutApp.CreateItem(0)
                    With OutMail
                        .To = rName.Offset(, 21)
                        .cc = rName.Offset(, 22)
                        .Subject = ""
                        .HTMLBody = RangetoHTML(rng)
                        .Display
                    End With
                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
Are you using a PC or a Mac?
 
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
773
skillilea
S
JohnPoole
  • Solved
Delete rows based on unique values
2
Replies
17
Views
891
kevin9999
K
J
  • Solved
VBA to compare rows in two different sheets, if match highlight cell
2
Replies
10
Views
650
kevin9999
K
N
  • Solved
Move entire row based on expiration date
2
Replies
17
Views
236
rollis13
rollis13
H
  • Solved
Macro to display message end of Code where Col D contains blanks
Replies
7
Views
341
howard
H

Forum statistics

Threads
1,215,098
Messages
6,123,082
Members
449,094
Latest member
mystic19

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