• DİKKAT

    DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
    Altın Üyelik Hakkında Bilgi

Malzeme sayısı sıfır olunca maila uyarı gönderme

K

kaygisiz11

Katılım
11 Aralık 2010
Mesajlar
4
Excel Vers. ve Dili
2010 Türkçe
Elimde bir adet depo listesi var. Bu listede malzemelerin sayıları yazıyor. Malzeme sayısı 1'e düştüğü zaman malzemelerin yer ve sayısı harıç tüm bilgileri yan yana yazılarak mail ile 4 farklı mail adrsine gönderilmesini istiyorum.
 

Ekli dosyalar

Son düzenleme:
Dosyanızı gönderin yardımcı olmaya çalışayım.
 
Şu kodları kullanabilirsiniz;

Kod: 
Sub Listele_Mail_At()
    Dim Rky As Object, Ert As Object
    Dim Sorgu As String
    Set Rky = CreateObject("Adodb.Connection")
    Set Ert = CreateObject("Adodb.RecordSet")
        Rky.Open "provider=microsoft.ace.oledb.12.0;data source=" & _
        ThisWorkbook.FullName & ";extended properties=""excel 12.0;hdr=no"""
        Sorgu = "Select F2,F3,F4,F5 from [Sayfa1$] where F6<=1"
        Ert.Open Sorgu, Rky, 1, 1
        Sayfa1.Range("b1:e1").Copy Sayfa2.Range("A1")
        Sayfa2.Range("A2").CopyFromRecordset Ert
        Ert.Close: Rky.Close
        Sayfa2.Select: Sayfa2.Columns.AutoFit
        Call Belirlene_Hucre_Araligini_Kitap_Olarak_Gonder
    Set Rky = Nothing: Set Ert = Nothing: Sorgu = vbNullString
End Sub


Sub Belirlene_Hucre_Araligini_Kitap_Olarak_Gonder()
    Sayfa2.Range("A1:D" & Sayfa2.Range("D65536").End(3).Row).Select
    Dim Source As Range
    Dim Dest As Workbook
    Dim wb As Workbook
    Dim TempFilePath As String
    Dim TempFileName As String
    Dim FileExtStr As String
    Dim FileFormatNum As Long
    Dim I As Long
    Set Source = Nothing
    On Error Resume Next
    Set Source = Selection.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
   If ActiveWindow.SelectedSheets.Count > 1 Or _
       Selection.Cells.Count = 1 Or _
       Selection.Areas.Count > 1 Then
        MsgBox "                   Bir hata oluştu:" & vbNewLine & vbNewLine & _
               "Seçim yapmadınız, hücre aralığını seçin.", vbOKOnly, "Www.ExcelVBA.Net"
        Exit Sub
    End If
  With Application
        .ScreenUpdating = False
        .EnableEvents = False
    End With
    Set wb = ActiveWorkbook
    Set Dest = Workbooks.Add(xlWBATWorksheet)
    Source.Copy
    With Dest.Sheets(1)
        .Cells(1).PasteSpecial Paste:=8
        .Cells(1).PasteSpecial Paste:=xlPasteValues
        .Cells(1).PasteSpecial Paste:=xlPasteFormats
        .Cells(1).Select
        Application.CutCopyMode = False
    End With
    TempFilePath = Environ$("temp") & "\"
    TempFileName = wb.Name & " " & Format(Now, "dd-mm-yyyy   h-mm-ss")
    If Val(Application.Version) < 12 Then
        'Excel 2000-2003
        FileExtStr = ".xls": FileFormatNum = -4143
    Else
        'Excel 2007-2010
        FileExtStr = ".xlsx": FileFormatNum = 51
    End If
    With Dest
        .SaveAs TempFilePath & TempFileName & FileExtStr, FileFormat:=FileFormatNum
        On Error Resume Next
        For I = 1 To 4
            .SendMail "[B][COLOR="Red"]Buraya Mail adreslerini aralarında ;(noktalı virgül) olacak şekilde yazın[/COLOR][/B]", "[B][COLOR="red"]Buraya Konuyu Yazın !!![/COLOR][/B]"
            If Err.Number = 0 Then Exit For
        Next I
        On Error GoTo 0
        .Close savechanges:=False
    End With
    Kill TempFilePath & TempFileName & FileExtStr
With Application
        .ScreenUpdating = True
        .EnableEvents = True
    End With
End Sub
 

Ekli dosyalar

Murat OSMA' Alıntı:
Şu kodları kullanabilirsiniz;

Kod: 
Sub Listele_Mail_At()
    Dim Rky As Object, Ert As Object
    Dim Sorgu As String
    Set Rky = CreateObject("Adodb.Connection")
    Set Ert = CreateObject("Adodb.RecordSet")
        Rky.Open "provider=microsoft.ace.oledb.12.0;data source=" & _
        ThisWorkbook.FullName & ";extended properties=""excel 12.0;hdr=no"""
        Sorgu = "Select F2,F3,F4,F5 from [Sayfa1$] where F6<=1"
        Ert.Open Sorgu, Rky, 1, 1
        Sayfa1.Range("b1:e1").Copy Sayfa2.Range("A1")
        Sayfa2.Range("A2").CopyFromRecordset Ert
        Ert.Close: Rky.Close
        Sayfa2.Select: Sayfa2.Columns.AutoFit
        Call Belirlene_Hucre_Araligini_Kitap_Olarak_Gonder
    Set Rky = Nothing: Set Ert = Nothing: Sorgu = vbNullString
End Sub


Sub Belirlene_Hucre_Araligini_Kitap_Olarak_Gonder()
    Sayfa2.Range("A1:D" & Sayfa2.Range("D65536").End(3).Row).Select
    Dim Source As Range
    Dim Dest As Workbook
    Dim wb As Workbook
    Dim TempFilePath As String
    Dim TempFileName As String
    Dim FileExtStr As String
    Dim FileFormatNum As Long
    Dim I As Long
    Set Source = Nothing
    On Error Resume Next
    Set Source = Selection.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
   If ActiveWindow.SelectedSheets.Count > 1 Or _
       Selection.Cells.Count = 1 Or _
       Selection.Areas.Count > 1 Then
        MsgBox "                   Bir hata oluştu:" & vbNewLine & vbNewLine & _
               "Seçim yapmadınız, hücre aralığını seçin.", vbOKOnly, "Www.ExcelVBA.Net"
        Exit Sub
    End If
  With Application
        .ScreenUpdating = False
        .EnableEvents = False
    End With
    Set wb = ActiveWorkbook
    Set Dest = Workbooks.Add(xlWBATWorksheet)
    Source.Copy
    With Dest.Sheets(1)
        .Cells(1).PasteSpecial Paste:=8
        .Cells(1).PasteSpecial Paste:=xlPasteValues
        .Cells(1).PasteSpecial Paste:=xlPasteFormats
        .Cells(1).Select
        Application.CutCopyMode = False
    End With
    TempFilePath = Environ$("temp") & "\"
    TempFileName = wb.Name & " " & Format(Now, "dd-mm-yyyy   h-mm-ss")
    If Val(Application.Version) < 12 Then
        'Excel 2000-2003
        FileExtStr = ".xls": FileFormatNum = -4143
    Else
        'Excel 2007-2010
        FileExtStr = ".xlsx": FileFormatNum = 51
    End If
    With Dest
        .SaveAs TempFilePath & TempFileName & FileExtStr, FileFormat:=FileFormatNum
        On Error Resume Next
        For I = 1 To 4
            .SendMail "[B][COLOR="Red"]Buraya Mail adreslerini aralarında ;(noktalı virgül) olacak şekilde yazın[/COLOR][/B]", "[B][COLOR="red"]Buraya Konuyu Yazın !!![/COLOR][/B]"
            If Err.Number = 0 Then Exit For
        Next I
        On Error GoTo 0
        .Close savechanges:=False
    End With
    Kill TempFilePath & TempFileName & FileExtStr
With Application
        .ScreenUpdating = True
        .EnableEvents = True
    End With
End Sub
Genişletmek için tıkla ...

Çok teşekkür ederim. Birde butona basınca değilde direk malzeme sayısı yerine 1 girilince eksik olan malzemeleri direk mailla göndersin. Onuda yapabilirseniz memnun olurum.
 
Son düzenleme:
Dediğiniz gibi olmaz.
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst