Çözüldü Her sayfayı farklı bir mail adresine gönderme

Private Sub CommandButton1_Click()
    Dim Sayfa As Worksheet
    Dim Alan As Range
    Dim daralan As Range
    If Cells(2, 2) = "" Then GoTo HATA
    On Error GoTo HATA
    With Application
        .ScreenUpdating = False
        .EnableEvents = False
    End With
    saydir = WorksheetFunction.CountIf(Range("A:A"), "<>") + 1
    DinamikAlan = "A1:" & "F" & saydir
    Set Alan = Worksheets("Sayfa1").Range(DinamikAlan)
    Set Sayfa = ActiveSheet
For dongu = 1 To 6
    With Alan
        .Parent.Select
        Set daralan = ActiveCell
        .Select
        ActiveWorkbook.EnvelopeVisible = True
        With .Parent.MailEnvelope
            .Introduction = "Otomatik Mail."
            With .Item
                .to = Cells(4, 8)
                '.CC = Cells(3, 2)
                .Subject = Cells(dongu, 1)
                .bcc = "hasmuh038@gmail.com"
                .Send
            End With
        End With
        daralan.Select
    End With
    Sayfa.Select
HATA:
    With Application
        .ScreenUpdating = True
        .EnableEvents = True
    End With
Next dongu
End Sub

Sub ExcelTurkey()
    Dim i%, dosya$, yeni As Workbook, out As Object, mail As Object
    Application.ScreenUpdating = False
    For i = 1 To Sheets.Count
        Sheets(i).Copy
        Set yeni = ActiveWorkbook
        yeni.Sheets(1).Range("H:P").Clear
        dosya = ThisWorkbook.Path & "\" & Range("B4").Value & ".xls"
        yeni.SaveAs Filename:=dosya, FileFormat:=xlNormal
        yeni.Close
        Set out = CreateObject("Outlook.Application")
        Set mail = out.CreateItem(0)
        With mail
            .To = Sheets(i).Range("H4").Value
            .Subject = "Buraya Konu Gelecek"
            .body = "Buraya Mesaj Gelecek"
            .attachments.Add dosya
            .display ' --> Ekrana getirir.
            '.Send   ' --> Gönderir.
        End With
        Kill dosya
    Next i
    MsgBox "İşlem Tamamlandı.", vbInformation, "Www.ExcelTurkey.Com"
    Application.ScreenUpdating = True
    i = Empty: dosya = vbNullString
    Set yeni = Nothing: Set out = Nothing: Set mail = Nothing
End Sub