Email keeps sending multiple emails, can't find what's causing to loop should only send 1

[cameodrifter]

Hello,
I need help with my automatic emailing excel spreadsheet. I have it set up to take a screenshot into a pdf then attach to email through outlook. It then also adds a temporary worksheet of another tab. The code works fine but every other day, it sends 5-7 emails of the same information. The file is set up to send only 1 email everyday at 7:00 am then transfers all data to database tab while also transferring certain cells' data to another "open" tab. It then sends the email then clears all data so it can resume again the next day.
Here's my code and all the modules.. Please help me and correct to only sending 1 email.

Sub SendSheet()
Application.OnTime TimeValue("07:00:00"), "EmailWithOutlook"
End Sub



Sub EmailWithOutlook()
    Dim oApp As Object
    Dim oMail As Object
    Dim WB As Workbook
    Dim FileName As String
    Dim wSht As Worksheet
    Dim shtName As String
    Dim IsCreated As Boolean
    Dim i As Long
    Dim PdfFile As String, Title As String
    Dim OutlApp As Object
 Application.ScreenUpdating = False
 Sheets("Passdown").Select
 ' Define PDF filename
  PdfFile = ActiveWorkbook.FullName
  i = InStrRev(PdfFile, ".")
  If i > 1 Then PdfFile = Left(PdfFile, i - 1)
  PdfFile = PdfFile & "_" & ActiveSheet.Name & ".pdf"


  ' Export activesheet as PDF
  With ActiveSheet
    .ExportAsFixedFormat Type:=xlTypePDF, FileName:=PdfFile, Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False
  End With
 
 
 Sheets("Open").Select
  ' Not sure for what the Title is
    Title = Range("E1")
   


    ' Make a copy of the active worksheet
    ' and save it to a temporary file
    ActiveSheet.Copy
    Set WB = ActiveWorkbook


    FileName = WB.Worksheets(1).Name & "Passdown"
    On Error Resume Next
    Kill "M:\Brandon Talmadge\My Spreadsheets\Maint Passdown\Temp" & FileName
    On Error GoTo 0
    WB.SaveAs FileName:="M:\Brandon Talmadge\My Spreadsheets\Maint Passdown\Temp" & FileName
     
        
        
   
 
  


    'Create and show the Outlook mail item
    Set oApp = CreateObject("Outlook.Application")
    Set oMail = oApp.CreateItem(0)
    With oMail
        'Uncomment the line below to hard code a recipient
        .To = "btalmad@dfamilk.com"
        .Cc = ""
        'Uncomment the line below to hard code a subject
        .Subject = "Maintenance Passdown for " & Title
        'Uncomment the lines below to hard code a body
        .body = "Hello," & vbLf & vbLf _
          & "Please see attached for Open Maintenance Tasks and Daily Passdown Report." & vbLf _
          & "Regards," & vbLf _
          & Application.UserName & vbLf & vbLf
        .Attachments.Add WB.FullName
        .Attachments.Add PdfFile
    
     On Error Resume Next
    .Send
    Application.Visible = True
    If Err Then
      MsgBox "E-mail was not sent", vbExclamation
    Else
      MsgBox "E-mail successfully sent", vbInformation
    End If
    On Error GoTo 0
   
  End With
 
  ' Delete PDF file
  Kill PdfFile
 
  ' Quit Outlook if it was created by this code
  If IsCreated Then OutlApp.Quit
 
  ' Release the memory of object variable
  Set OutlApp = Nothing
 


    'Delete the temporary file
    WB.ChangeFileAccess Mode:=xlReadOnly
    Kill WB.FullName
    WB.Close SaveChanges:=False


    'Restore screen updating and release Outlook
    Application.ScreenUpdating = True
    Set oMail = Nothing
    Set oApp = Nothing
    TransferData
End Sub


Sub TransferData()


With Range("E1")
    .Value = Date
    .NumberFormat = "MMM DD YYYY"
 End With
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Dim rng1 As Range
Set ws1 = Sheets("Passdown")
Set ws2 = Sheets("Database")
On Error Resume Next
Set rng1 = ws1.Columns("A").SpecialCells(xlConstants)
On Error GoTo 0
If rng1 Is Nothing Then Exit Sub
Application.ScreenUpdating = False
CopyRows
Dim NextRow As Long
NextRow = ws2.Cells.Find("*", ws2.Cells(1), , , xlByRows, xlPrevious).Row + 1
Set rng2 = ws2.Range("A" & NextRow)


rng1.Copy rng2
rng1.Offset(0, 1).Copy rng2.Offset(0, 1)
rng1.Offset(0, 2).Copy rng2.Offset(0, 2)
rng1.Offset(0, 3).Copy rng2.Offset(0, 3)
rng1.Offset(0, 4).Copy rng2.Offset(0, 4)
rng1.Offset(0, 5).Copy rng2.Offset(0, 5)
rng1.Offset(0, 6).Copy rng2.Offset(0, 6)
rng1.Offset(0, 19).Copy rng2.Offset(0, 8)
rng2.Offset(0, 7).Resize(rng1.Cells.Count, 1) = Sheets("Passdown").Range("E1")
Application.ScreenUpdating = True
Sheets("Chart").Select
    ActiveSheet.ChartObjects("Chart 1").Activate
    ActiveChart.PivotLayout.PivotTable.PivotCache.Refresh
    
Clear
Sheets("Passdown").Select
Range("T4").Copy
    Range("E1").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
ActiveWorkbook.Save
End Sub
Sub CopyRows()
Sheets("Passdown").Select
Range("E1").Select
    Application.CutCopyMode = False
    Selection.Copy
    Range("H6:H61").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
Dim bottomL As Integer
bottomL = Sheets("Passdown").Range("F" & Rows.Count).End(xlUp).Row


Dim c As Range
For Each c In Sheets("Passdown").Range("F1:F" & bottomL)
If c.Value = "Open" Then
c.EntireRow.Copy Worksheets("Open").Range("A" & Rows.Count).End(xlUp).Offset(1)
End If
Next c
   Sheets("Open").Select
   Range("I2:I199").FormulaR1C1 = "=IF(ISBLANK(RC[-1]),0,R1C9-RC[-1])"
   Columns("H:H").Select
   Selection.NumberFormat = "m/d/yyyy"
   Sheets("Passdown").Select
      Range("H6:H61").Select
        Selection.ClearContents
        Range("A6").Select
    
End Sub








Sub Clear()
Sheets("Passdown").Select
Range("A6:G33,A35:G61").Select
    Selection.ClearContents
    Range("A6").Select
SendSheet
End Sub

 

[Logit]

.
Here are the steps of your macros :

[TABLE="width: 64"]
<colgroup><col width="64" style="width:48pt"> </colgroup><tbody>[TR]
[TD="width: 64"]Start with:

SendSheet

[/TD]
[/TR]
[TR]
[TD]Go To :

EmailWithOutlook[/TD]
[/TR]
[TR]
[TD]
Takes You To :

TransferData[/TD]
[/TR]
[TR]
[TD]
Directs You To :

Clear .. Which then takes you back to SendSheet[/TD]
[/TR]
[TR]
[TD]and the circle begins again.[/TD]
[/TR]
[TR]
[TD][/TD]
[/TR]
[TR]
[TD]Remove :

"SendSheet" from the "Clear" macro and see if it sends only once.[/TD]
[/TR]
</tbody>[/TABLE]