Multiple Email Attachments not wanted

[Pete2507]

Hi Everyone
I have a code that works pretty sweet except it attachs multiple attachment to one email. i would like it to attach each new file to a new email and send via range below.
Can anyone help??

Many Thanks
Pete

Sub EmailTechProgress()


    Dim Source As Range
    Dim Dest As Workbook
    Dim wb As Workbook
    Dim ws As Worksheet
    Dim TempFilePath As String
    Dim TempFileName As String
    Dim FileExtStr As String
    Dim FileFormatNum As Long
    Dim OutApp As Object
    Dim OutMail As Object
    Dim rngCell As Range

    Set wb = ActiveWorkbook
    Set ws = ActiveSheet

    Set Source = Nothing
    On Error Resume Next
    Set Source = ws.Range("sendout").SpecialCells(xlCellTypeVisible)
    On Error GoTo 0

    If Source Is Nothing Then
        MsgBox "The source is not a range or the sheet is protected, " & _
            "please correct and try again.", vbOKOnly
        Exit Sub
    End If

    With Application
        .ScreenUpdating = False
        .EnableEvents = False
    End With

    If Val(Application.Version) < 12 Then
        'You use Excel 97-2003
        FileExtStr = ".xls"
        FileFormatNum = -4143
    Else
        'You use Excel 2007-2013
        FileExtStr = ".xlsx"
        FileFormatNum = 51
    End If

    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(0)

    ' Loop through source of dropdown list - *** modify as needed ***
    For Each rngCell In wb.Worksheets("totals").Range("A177:A179")
        ' Set the value of A1
        ws.Range("c2").Value = rngCell.Value
        Set Dest = Workbooks.Add(xlWBATWorksheet)

        Source.Copy
        With Dest.Sheets(1)
            .Cells(1).PasteSpecial Paste:=xlPasteColumnWidths
            .Cells(1).PasteSpecial Paste:=xlPasteValues
            .Cells(1).PasteSpecial Paste:=xlPasteFormats
            .Cells(1).Select
            Application.CutCopyMode = False
        End With

        TempFilePath = Environ$("temp") & "\"
        TempFileName = "High 5 Compliance"

        With Dest
            .SaveAs TempFilePath & TempFileName & FileExtStr, FileFormat:=FileFormatNum
            On Error Resume Next
            With OutMail
                .To = ws.Range("email")
                .CC = ""
                .BCC = ""
                .Subject = "Test"
                .Body = "Tester"
                .Attachments.Add Dest.FullName
                .Display   'or use .Display
            End With
On Error GoTo 0
            .Close SaveChanges:=False
        End With

        Kill TempFilePath & TempFileName & FileExtStr
    ' On to the next cell
        Next rngCell

    Set OutMail = Nothing
    Set OutApp = Nothing

    With Application
        .ScreenUpdating = True
        .EnableEvents = True
    End With
    
End Sub