• Merhaba Ziyaretçi,
    Microsoft 365 Uygulamaları ile ilgili yeni haberler, dikkat çekici konular, ilgi ile takip edeceğiniz yazılar için.

    Abone Olun
  • ESTE - Microsoft Office Eğitimleri

    Yeni yıl Microsoft Office Eğitim planlarınız için bütçenizi oluşturmadan önce ESTE eğitim kalitesi ile tanışın. 🙌
    Kullanıcıların ihtiyacı olan yazılı materyal, dosya ve video kaynağı desteğimiz ile tüm ofis çalışanlarının iş süreçlerini rahatlatacak eğitimler planlayın. 🎯
    Microsoft Office eğitimlerimiz hakkında detaylı bilgi için bize ulaşın.

    👉 Microsoft Office Eğitim Talebi

Uygulama Belirtilen Hücre Aralığını Boş Kitap İçinde Mail'e Ek Yapmak

Murat OSMA

Yönetici
Site Yöneticisi
Katılım
25 May 2018
Mesajlar
1,486
En iyi yanıt
13
Puanları
113
Konum
İstanbul
Web sitesi
excelarsivi.com
Ad Soyad
Murat OSMA
Office Vers.
Office 365 TR+EN
Kodlarda belirtilen hücre aralığını ayrı bir dosya olarak mesaja eklemek için bu kodları kullanabilirsiniz. (y)

PHP:
Sub Belirlene_Hucre_Araligini_Kitap_Olarak_Ekle()
    Dim Source As Range, Dest As Workbook, wb As Workbook
    Dim TempFilePath$, TempFileName$, FileExtStr$
    Dim FileFormatNum&, I As Long
    Range("A1:D11").Select
    Set Source = Nothing
    On Error Resume Next
    Set Source = Selection.SpecialCells(xlCellTypeVisible)
    On Error GoTo 0
    If Source Is Nothing Then
        MsgBox "Kaynak bir aralık değildir veya sayfa korunur" & ", lütfen düzeltin ve tekrar deneyin.", 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.ExcelTurkey.Com"
        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-2016
        FileExtStr = ".xlsx": FileFormatNum = 51
    End If
    With Dest
        .SaveAs TempFilePath & TempFileName & FileExtStr, FileFormat:=FileFormatNum
        On Error Resume Next
        For I = 1 To 3
            .SendMail "", "Buraya Konuyu Yazın !!!"
            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
Dosyayı ek'ten de indirebilirsiniz.
 

Ekli dosyalar

  • Belirlenen Hücre Aralığını Boş Kitap İçinde Mail Atar.rar
    19.1 KB · Görüntüleme: 16
Üst Alt