VBA - Email Loop Issue

[JonnyBT123]

Hi all,

I’ve spent some time creating (and also modifying from RonDe Bruin) an emailer, where basically my control page (named SYSINI) has namesin column A, email addresses in column B and a Yes or No in column D.
If D2 says Yes:
Copy page called “Emailer”,rename to the email address, copy/paste full new page as values, send as email attachmentto the email address in B2, delete the page with the email address name, and repeatfor each row.
If not, move on to D3 etc andloop until the row in column D is blank.

I’ve got the part where it does the copy/paste/rename of thepage etc, but when adding the emailer around it, so it sends the email, I justget the code looping and skips everything between where I’ve marked ‘’’**SKIPSHERE** until the part marked ‘’’**UNTIL HERE**


Any idea where I’m going wrong please? There are no errorcodes, just a continuous loop with nothing happening.

Sub SendEmails()
'
' Sendemails Macro
'

Dim OutApp As Object
Dim OutMail As Object
Dim ShtName As String
Dim SavName As String
Dim cell As Range
Dim ws As Worksheet

 Application.ScreenUpdating = False
    Set OutApp = CreateObject("Outlook.Application")
Set ws = Worksheets("SYSINI")
    
On Error GoTo cleanup
For Each cell In ws.Columns("B").Cells.SpecialCells(xlCellTypeConstants)
    If cell.Value Like "?*@?*.?*" And _
    LCase(Cells(cell.Row, "D").Value) = "yes" Then
    
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'''***SKIPS EVERYTHING BELOW HERE....**   
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

    Range(cell.Row, "B").Select
    Selection.Copy
    ws.Range("M1").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Application.CutCopyMode = False
    

    ShtName = ws.Range("M1").Value
    SavName = ShtName & "_" & ws.Range("H1")
    
    
    Sheets("Emailer").Select
    Range("F13").Select
    ActiveCell.FormulaR1C1 = _
        "=IFERROR(VLOOKUP(LEFT(SYSINI!R1C13,LEN(SYSINI!R1C13)-7)&ROW(RC[-1])-12,NewPivot!C3:C9,COLUMN(R[-11]C),FALSE),"""")"
    
    Range("F14").Select
    
    Sheets("Emailer").Copy Before:=Sheets(7)
    Sheets("Emailer (2)").Select
    Sheets("Emailer (2)").Name = ShtName
    
    Cells.Select
    Selection.Copy
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Application.CutCopyMode = False
    
    ActiveSheet.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True
    Sheets(ShtName).Select
    
       Sheets(Array("Report1", "Processes", "NewPivot", "Emailer", "Completed" _
        , "SYSINI")).Select
    ActiveWindow.SelectedSheets.Visible = False
    
    
        ActiveWorkbook.SaveAs FileName:= _
        "C:/SharepointServerAddressHere" & ShtName & SavName & ".xlsm" _
        , FileFormat:=xlOpenXMLWorkbookMacroEnabled, CreateBackup:=False
    Sheets(ShtName).Select
     
     Set OutMail = OutApp.CreateItem(0)
            On Error Resume Next
            With OutMail
                .To = cell.Value
                .Subject = "Reminder"
                .Body = "Dear " & Sheets("SYSINI").Range("L1").Value _
                      & vbNewLine & vbNewLine & _
                        "Please see attached for you to action."
                        
                
                .Attachments.Add ("MySharePointServerAddressAgain/" & ShtName & SavName & ".xlsm")
                
                .Display  'Or use Send
                
            End With
            On Error GoTo 0
            Set OutMail = Nothing
        End If
   

     '''''''''''''''''''''''''''''''''

    '''**UNTIL HERE**
    '''''''''''''''''''''''''''''''''''


    Sheets("Report1").Visible = True

     Sheets("NewPivot").Visible = True
        Sheets("Processes").Visible = True
 
        Sheets("Emailer").Visible = True
 
        Sheets("Completed").Visible = True
 
        Sheets("SYSINI").Visible = True
 
 
     Application.DisplayAlerts = False
    Sheets(ShtName).Delete
    Sheets("SYSINI").Select
    Application.DisplayAlerts = True
    
 Next cell
     
cleanup:
    Set OutApp = Nothing
    Application.ScreenUpdating = True
    
End Sub

 

[John_w]

I’ve got the part where it does the copy/paste/rename of thepage etc, but when adding the emailer around it, so it sends the email, I justget the code looping and skips everything between where I’ve marked ‘’’**SKIPSHERE** until the part marked ‘’’**UNTIL HERE**

Which suggests this If statement is evaluating to False:

    If cell.Value Like "?*@?*.?*" And _
    LCase(Cells(cell.Row, "D").Value) = "yes" Then

Try changing it to:

   If cell.Value Like "?*@?*.?*" And _
    LCase([COLOR=#ff0000][B]ws.[/B][/COLOR]Cells(cell.Row, "D").Value) = "yes" Then

 

[JonnyBT123]

Which suggests this If statement is evaluating to False:

    If cell.Value Like "?*@?*.?*" And _
    LCase(Cells(cell.Row, "D").Value) = "yes" Then

Try changing it to:

   If cell.Value Like "?*@?*.?*" And _
    LCase([COLOR=#ff0000][B]ws.[/B][/COLOR]Cells(cell.Row, "D").Value) = "yes" Then

Thank you for your quick response John, however I've added the 'ws.' in and still no change It's frustrating as I'm not a novice at this, but certainly no expert. I'm able to write / amend vba no problem usually, but this is just perplexing me

 

[John_w]

I've added MsgBox statements for debugging purposes.

Is there a leading or trailing space in the column D value? Use the Trim function to ignore them:

    For Each cell In ws.Columns("B").Cells.SpecialCells(xlCellTypeConstants)
        MsgBox cell.Address & " >" & cell.Value & "<" & vbNewLine & _
                ws.Cells(cell.Row, "D").Address & " >" & ws.Cells(cell.Row, "D").Value & "<"
        If cell.Value Like "?*@?*.?*" And _
            LCase(Trim(ws.Cells(cell.Row, "D").Value)) = "yes" Then
                MsgBox "Send to " & cell.Value
        End If
    Next

 

[JonnyBT123]

I've added MsgBox statements for debugging purposes.

Is there a leading or trailing space in the column D value? Use the Trim function to ignore them:

    For Each cell In ws.Columns("B").Cells.SpecialCells(xlCellTypeConstants)
        MsgBox cell.Address & " >" & cell.Value & "<" & vbNewLine & _
                ws.Cells(cell.Row, "D").Address & " >" & ws.Cells(cell.Row, "D").Value & "<"
        If cell.Value Like "?*@?*.?*" And _
            LCase(Trim(ws.Cells(cell.Row, "D").Value)) = "yes" Then
                MsgBox "Send to " & cell.Value
        End If
    Next

John, thanks once again for your reply. I've added your part in and the first pop up show correctly the email address for $b$2, and "yes" for $d$2. The second pop up then shows "Send to" and the correct email address, which seems fine.
There are no gap in column D, just 'Yes' or 'No' until the blanks at the end of the list.
After clicking 'OK' it now goes down to

 Range(cell.Row, "B").Select

which is highlighted, then skips the rest and goes to the cleanup.

Would this imply there's an issue with the cell.Row, "B" select?

Appreciate the quick replies and the attempts for resolution.

 

[John_w]

Delete the On Error GoTo cleanup, as that just hides any errors in the code. Without that line you can debug the code properly.

 

[JonnyBT123]

Delete the On Error GoTo cleanup, as that just hides any errors in the code. Without that line you can debug the code properly.

I'll be sure to give that a go. Will keep you posted with the results
Thanks again!

 

[JonnyBT123]

Ok, so I’ve taken out the ‘On Error GoTo cleanup’ out, andit errors on

 Range(cell.Row, “B”).Select

but I can’t work out why.
I get ‘Run-time error ‘1004’: Method ‘Range’ of object ‘_Global’failed.
There are no objects surely? Maybe I don’t know as much as Ithought about vba haha.

 

[JonnyBT123]

Yes! I’ve solved it. I just replaced:

 Range(cell.Row, “B”).Select

With

 ws.Cells(cell.Row, "B").Select

Thanks for your help with the matter John, much appreciated!