Copying, Pasting, Creating Emails

ekahler

New Member
Joined
Nov 19, 2009
Messages
5
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

Code:
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
 

Some videos you may like

Excel Facts

Lock one reference in a formula
Need 1 part of a formula to always point to the same range? use $ signs: $V$2:$Z$99 will always point to V2:Z99, even after copying

ekahler

New Member
Joined
Nov 19, 2009
Messages
5
I got something that I like better to work, however, it's still catching on that second loop... :(

Code:
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
 

Watch MrExcel Video

Forum statistics

Threads
1,123,259
Messages
5,600,575
Members
414,390
Latest member
plimbu

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
Top