Makro ile Mail Atma Sorunu

[oguz demirbas]

Merhabalar;
Aşağıda eklediğim dosya ile toplu mail atmak istiyorum. Ancak döngü kurgusunda bir hata yapıyorum.
Ek teki sitede sorun yaşadığım yer TOPLU MAİL AT butonu.
Yardımlarınız için teşekkür ederim.

Not: Deneme sırasında mail atabilir.

Private Sub CommandButton4_Click()


Sheets("Sayfa3").Select
Range("A5:CD676").Select
Selection.ClearContents
Sheets("Sayfa1").Select
ListBox1.Clear
Label6.Caption = ""
If cbaylar.Value = "" Then
MsgBox (" Lütfen AY seçiniz.")
Exit Sub
End If

Dim bak As Range
For Each bak In Sheets("rowsource").Range("n1:n" & WorksheetFunction.CountA(Range("n1:n11")))

cbmakine.Value = bak
Sheets("print2").Select
Sheets("Sayfa1").Select
ActiveSheet.Range("$A$2:$CX$1000").AutoFilter Field:=12, Criteria1:=">=" & CLng(CDate(CLng(CDate(TextBox1)))), Operator:=xlAnd, Criteria2:="<=" & CLng(CDate(CLng(CDate(TextBox2))))
ActiveSheet.Range("$A$2:$CX$1000").AutoFilter Field:=14, Criteria1:="=" & bak

    Range("A11:BA8320").Select
    Range("BA11").Activate
    Selection.Copy
    Sheets("Sayfa3").Select
    Range("A3").Select
    ActiveSheet.Paste
    Application.CutCopyMode = False
    Range("A3:BA8000").Select
    ActiveWorkbook.Worksheets("Sayfa3").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("Sayfa3").Sort.SortFields.Add Key:=Range("L3:L1000" _
        ), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    With ActiveWorkbook.Worksheets("Sayfa3").Sort
        .SetRange Range("A3:BA8000")
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With

Range("A3").Select
ListBox1.ColumnCount = 5
ListBox1.ColumnWidths = "35;200;50;100;50"
ListBox1.Clear
    Sheets("Sayfa3").Select
    Dim bak2 As Range
    For Each bak2 In Range("n1:n" & WorksheetFunction.CountA(Range("n1:n6500")))
        If StrConv(bak2.Value, vbUpperCase) = StrConv(cbmakine.Value, vbUpperCase) Then
            bak2.Select
ActiveCell.Offset(0, -2).Value = Format((ActiveCell.Offset(0, -2).Value), "dd.mm.yyyy hh.mm ")
ListBox1.AddItem
ListBox1.Column(0, sat) = (ActiveCell.Offset(0, -5).Value)
ListBox1.Column(1, sat) = (ActiveCell.Offset(0, -12).Value)
ListBox1.Column(2, sat) = (ActiveCell.Offset(0, -8).Value)
ListBox1.Column(3, sat) = (ActiveCell.Offset(0, -2).Value)
ListBox1.Column(4, sat) = (ActiveCell.Offset(0, -1).Value)
'ListBox1.Column(4, sat) = Format(ListBox1.Column(4, sat), "#,##0")
'ListBox1.Column(4, sat) = Replace(ListBox1.Column(4, sat), ",", ".")
sat = sat + 1
End If
Next bak2
Label6.Caption = ListBox1.ListCount
'''''''''''''Label8.Caption = Range("ca5").Value
Range("m500").Value = WorksheetFunction.Sum(Range("m3:m499"))
Label10.Caption = CDbl(Range("m500").Value)
Label10 = Format(Label10, "#,##0")
Sheets("Sayfa1").Select
Range("A4:CD4").Select
Selection.AutoFilter
Sheets("print2").Select
Range("A7:d3650").Select
Selection.ClearContents
Dim Data() As Variant
Dim i As Long
 
    ReDim Data(ListBox1.ListCount - 1, 4)
 
        For i = 0 To UBound(Data)
        Data(i, 0) = ListBox1.List(i, 0)
        Data(i, 1) = ListBox1.List(i, 1)
        Data(i, 2) = ListBox1.List(i, 4)
        ListBox1.List(i, 4) = CDbl(ListBox1.List(i, 4))
        Data(i, 3) = ListBox1.List(i, 3)
        'Data(i, 4) = ListBox1.List(i, 4)
        'Data(i, 5) = ListBox1.List(i, 5)
       'Data(i, 5) = Format(Data(i, 5), "dd.mm.yyyy")
      Next i
   Range("A7").Resize(i, 4) = Data
   Range("c2").Value = cbmakine.Value
   Range("a1").Value = TextBox1.Value & " ile " & TextBox2.Value & " TARİHLERİ ARASINDAKİ BASKI RAPORUDUR"
   Range("c5").Value = Label6.Caption & "  Adet  "
   Range("c4").Value = Label10.Caption & "  Tabaka "
   Application.ScreenUpdating = False
ActiveSheet.PageSetup.Orientation = xlLandscape

Sheets("print2").Select
    
ActiveSheet.PageSetup.Orientation = xlLandscape


Sheets("print2").Select
Application.Visible = True
Dim Sayfa As Worksheet
    Dim Alan As Range
    Dim daralan As Range
 
    With Application
        .ScreenUpdating = False
        .EnableEvents = False
    End With
'Mail tablosuna dinamiklik kazandırmak için tabloda kaç satır olduğunu bulur.
    saydir = WorksheetFunction.CountIf(Range("A:A"), "<>") + 1
'Dinamik alan tanımlanır.
  DinamikAlan = "A1:" & "j" & saydir
'Dinamik alan mail alanı olarak kurulur.
Set Alan = Worksheets("Print2").Range(DinamikAlan)
    
    Set Sayfa = ActiveSheet
 
    With Alan
 
        .Parent.Select
        Set daralan = ActiveCell
 
        .Select
        ActiveWorkbook.EnvelopeVisible = True
        With .Parent.MailEnvelope
 
            .Introduction = (Cells(1, 3)) & "  Zafer Bekyürek / Kalite Kontrol Şefi"
 
            With .Item
                .To = "uretim@rubinofset.com.tr"
                .CC = "rubin@rubinofset.com.tr"
                .Subject = Cells(1, 1) & " ÜRETİM RAPORUDUR "
                .bcc = "oguzdemirbas@hotmail.com"
                .Send
            End With
 
        End With
 
        daralan.Select
    End With
    
    Sayfa.Select


'Sheets("Sayfa3").Select
Range("A5:CD676").Select
Selection.ClearContents
Sheets("Sayfa1").Select
ListBox1.Clear
Label6.Caption = ""
Next bak
 MsgBox (" Toplu Mail Başarılı Bir Şekilde Atıldı.")
End Sub

 

[oguz demirbas]

Up

 

[oguz demirbas]

Up

 

[oguz demirbas]

up