For...Next Loop issue

I wrote a macro for Excel 2003 and 2007 that send e-mail directly from Excel, extracting the address, file to attach and division from three columns. The macro works superbly well, except for the loop which doesn't work at all.

Complete code:

Sub Mail_Discretionary()
    
    Dim OutApp As Object
    Dim OutMail As Object

    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(0)
    
    Dim month As Integer
    month = Range("B2").Value

    Dim annee As String
    annee = Range("B12").Value
    
    
    Dim Email As String
    Dim Folder As String
    Dim dept As String
    Dim i As Integer
        
For i = 1 To 150
    Windows("Macro Email Sending.xlsm").Activate
    Range("E4").Select
    dept = ActiveCell.Offset(i, 0).Value
    Folder = ActiveCell.Offset(i, 1).Value
    Email = ActiveCell.Offset(i, 2).Value
    'If dept = "" Then
     '   Stop
    'Else
    'On Error Resume Next
   
    With OutMail
        .To = Email
        .CC = ""
        .BCC = ""
        .Subject = "Forecast "
        .Body = "Please find your report attached."
        .Attachments.Add "C:\Financial Reporting & Budgeting\FY Forecast\CURRENT MONTH\" & Folder & "\Discretionary Report - " & dept & ".xlsm"
        .Display
        
     End With
    'Set OutMail = Nothing
    'Set OutApp = Nothing
    'End If
Next i
    
End Sub

As it is now, it adds all attachments to a single e-mail rather than one e-mail for each rows...