Copying, Pasting, Creating Emails

[ekahler]

Getting frustrated - I know the below is UGLY

Essentially, I have a list of supervisors and a # category that tells me what information they are missing. I want to find which employees they are missing reviews and/or goal forms for, create an email, and email them the names of the employees who are missing data (with some additional language)

Can anyone help? I'm sure there will be questions in order to provide solutions, but... I'm frazzled looking at this at the moment

Private Sub Email2()
Dim Subject As String
Dim oApp As Object, _
oMail As Object, _
WB As Workbook, _
FileName As String
Dim SupvName As String
Dim c
Dim z
Dim d
'0 is All Done
'1 is Training
'3 is Reviews
'4 is Training & Reviews
'5 is Goals
'6 is Training & Goals
'8 is Reviews & Goals
'9 is Training, Reviews, & Goals
'Turn off screen updating
Application.ScreenUpdating = False

With Worksheets("Master Spvr").Range("I2")
   Range("I2").Activate
SupvName = ActiveCell.Offset(0, -8).Value
    For Each c In Range("I2:I8")
         
            If ActiveCell.Value = 1 Then
            
            'Create and show the outlook mail item
                Set oApp = CreateObject("Outlook.Application")
                Set oMail = oApp.CreateItem(0)
                With oMail
                .To = ActiveCell.Offset(0, -8)
                .Subject = "Performance Management - Pending Items"
                .Body = "You have not completed the mandatory Supervisor Training module on Performance Management. "
                .Display
                End With
                
            
            ElseIf ActiveCell.Value = 3 Then
            
            With Worksheets("No Review").Range("B3:B6")
                Worksheets("No Review").Select
                Range("B3").Select
                For Each z In Range("B3:B6")
                If Selection = SupvName Then
                    ActiveCell.Offset(0, -1).Select
                     Selection.Copy
                        If SheetExists2(SupvName) Then
                        Worksheets(SupvName).Select
                        End If
                    Selection.End(xlDown).Select
                    ActiveCell.Offset(1, 0).Range("A1").Select
                    ActiveSheet.Paste
                    Selection.End(xlUp).Select
                End If
                'HERE IS WHERE IT GETS STUCK AND DOES NOT ROTATE THROUGH THE LIST OF EMPLOYEES ON THE 'NO REVIEW' WORKSHEET
           ActiveCell.Offset(1, 0).Select
                Next z
            End With
            With Worksheets("Master Spvr")
                Worksheets("Master Spvr").Activate
            'Create and show the outlook mail item
                Set oApp = CreateObject("Outlook.Application")
                Set oMail = oApp.CreateItem(0)
                With oMail
                .To = ActiveCell.Offset(0, -7)
                .Subject = "Performance Management - Pending Items"
                .Body = "You have reviews to do"
                .Display
                End With
            End With
            
            Else:
            'Create and show the outlook mail item
                Set oApp = CreateObject("Outlook.Application")
                Set oMail = oApp.CreateItem(0)
                With oMail
                .To = ActiveCell.Offset(0, -7)
                .Subject = "Performance Management - Pending Items"
                .Body = "Sorry"
                .Display
                End With
  
            End If
     
     ActiveCell.Offset(1, 0).Select

Next c
'Restore screen updating and release Outlook
    Application.ScreenUpdating = True
    Set oMail = Nothing
    Set oApp = Nothing

End With
End Sub

 

[ekahler]

I got something that I like better to work, however, it's still catching on that second loop...

Sub CreateEmail()
Dim SpvrName As String
Dim oApp As Object
Dim oMail As Object
Dim rng As Range
Dim EmailCode
Dim z
 
With Worksheets("Master Spvr").Range("I2:I8")
    Range("I2").Activate
 
 
    For Each EmailCode In Range("I2:I8")
     SpvrName = ActiveCell.Offset(0, -8).Value
        If ActiveCell = 3 Then
                With Worksheets("No Review").Range("B3:B6")
                Worksheets("No Review").Activate
                Range("B3").Activate
                    For Each z In Range("B3:B6")
                        If ActiveCell = SpvrName Then
                            ActiveCell.Offset(0, -1).Select
                            Selection.Copy
                                If SheetExists2(SpvrName) Then
                                Worksheets(SpvrName).Select
                                End If
                            Selection.End(xlDown).Select
                            ActiveCell.Offset(1, 0).Select
                            ActiveSheet.Paste
                            Selection.End(xlUp).Select
                        End If
                    
                    With Worksheets("No Review")
                        Worksheets("No Review").Select
                    ActiveCell.Offset(1, 0).Select
                    
                    End With
                
                    Next z
                
                With Worksheets(SpvrName)
                Worksheets(SpvrName).Select
                Worksheets(SpvrName).Range("A1:A22").Select
                
                End With
                Set rng = Selection
                 On Error GoTo 0
   If rng Is Nothing Then
        MsgBox "The selection is not a range or the sheet is protected" & _
               vbNewLine & "please correct and try again.", vbOKOnly
        Exit Sub
    End If
    With Application
        .EnableEvents = False
        .ScreenUpdating = False
    End With
            With Worksheets("Master Spvr")
               Worksheets("Master Spvr").Activate
        Set oApp = CreateObject("Outlook.Application")
        Set oMail = oApp.CreateItem(0)
        With oMail
         
               
         
                .To = ActiveCell.Offset(0, -7)
                .Subject = "Performance Management - Pending Items"
                 .HTMLBody = RangetoHTML(rng)
                 .Display
                '.Send   'or use .Display
        End With
        End With
    On Error GoTo 0
    With Application
        .EnableEvents = True
        .ScreenUpdating = True
    End With
    Set oMail = Nothing
    Set oApp = Nothing
                
                End With
            With Worksheets("Master Spvr")
                Worksheets("Master Spvr").Activate
                ActiveCell.Offset(1, 0).Select
            End With
       
        End If
    Next EmailCode
 
End With
   
End Sub
Function RangetoHTML(rng As Range)
' Changed by Ron de Bruin 28-Oct-2006
' Working in Office 2000-2007
    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"
 
    'Copy the range and create a new workbook to past the data in
    rng.Copy
    Set TempWB = Workbooks.Add(1)
    With TempWB.Sheets(1)
        .Range("A1:A12").PasteSpecial Paste:=8
        .Range("A1:A12").PasteSpecial xlPasteValues, , False, False
        .Range("A1:A12").PasteSpecial xlPasteFormats, , False, False
        .Range("A1:A12").Select
        Application.CutCopyMode = False
        On Error Resume Next
        .DrawingObjects.Visible = True
        .DrawingObjects.Delete
        On Error GoTo 0
    End With
 
    'Publish the sheet to a htm file
    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
 
    'Read all data from the htm file into RangetoHTML
    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=")
 
    'Close TempWB
    TempWB.Close savechanges:=False
 
    'Delete the htm file we used in this function
    Kill TempFile
 
    Set ts = Nothing
    Set fso = Nothing
    Set TempWB = Nothing
End Function
Function SheetExists2(SpvrName As String) As Boolean
    Dim ws As Worksheet
    On Error Resume Next
    Set ws = Worksheets(SpvrName)
    If Not ws Is Nothing Then SheetExists2 = True
End Function