• DİKKAT

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

autofilter ile filtre edilen sayfayı mail ile atmak

C:\Users\CASPER\Desktop\tpl\P14\purpledarkness\Yeni Klasör
Aşağıdaki dosyayı deneyiniz
Kod: 
Function Kriterler(BaslikAlti As Range) As String
Dim Filter As String
Filter = ""
On Error GoTo SON
With BaslikAlti.Parent.AutoFilter
If Intersect(BaslikAlti, .Range) Is Nothing Then GoTo SON
With .Filters(BaslikAlti.Column - .Range.Column + 1)
If Not .On Then GoTo SON
Filter = Replace(.Criteria1, "=", """", 2)
Filter2 = Replace(.Criteria2, "=", """", 2)

Select Case .Operator
Case xlAnd
Filter = Filter & " ve " & Filter2
Case xlOr
Filter = Filter & " veya " & Filter2
End Select

End With
End With
SON:
Kriterler = Filter
End Function
Kod: 
Public snc As String 'Cells(strno - 5, 1).Value
Sub AktifSayfayıPostala()
    Dim TempFilePath, TempFileName, FileExtStr As String
    Dim FileFormatNum                          As Long
    Dim Sourcewb, Destwb                       As Workbook
    Dim OutApp, OutMail                        As Object
    

    With Application
        .ScreenUpdating = False
        .EnableEvents = False
    End With

    Set Sourcewb = ActiveWorkbook
    'Copy the sheet to a new workbook
    ActiveSheet.Copy:    Set Destwb = ActiveWorkbook

    'Determine the Excel version and file extension/format
    With Destwb
        If Val(Application.Version) < 12 Then
            'You use Excel 97-2003
            FileExtStr = ".xls": FileFormatNum = -4143
        Else
            'You use Excel 2007
            'We exit the sub when your answer is NO in the security dialog that you only
            'see  when you copy a sheet from a xlsm file with macro's disabled.
            If Sourcewb.Name = .Name Then
                With Application
                    .ScreenUpdating = True
                    .EnableEvents = True
                End With
                MsgBox "Your answer is NO in the security dialog"
                Exit Sub
            Else
                Select Case Sourcewb.FileFormat
                Case 51: FileExtStr = ".xlsx": FileFormatNum = 51
                Case 52:
                    If .HasVBProject Then
                        FileExtStr = ".xlsm": FileFormatNum = 52
                    Else
                        FileExtStr = ".xlsx": FileFormatNum = 51
                    End If
                Case 56: FileExtStr = ".xls": FileFormatNum = 56
                Case Else: FileExtStr = ".xlsb": FileFormatNum = 50
                End Select
            End If
        End If
    End With

    ek = snc
    If ek = "" Then ek = "Tüm dosya"
   'Save the new workbook/Mail it/Delete it
    TempFilePath = Environ$("temp") & "\"
    TempFileName = "Part of " & Sourcewb.Name & " " & Format(Now, "dd-mmm-yy h-mm-ss")

    Set OutApp = CreateObject("Outlook.Application")
    OutApp.Session.Logon
    Set OutMail = OutApp.CreateItem(0)

    With Destwb
        .SaveAs TempFilePath & TempFileName & FileExtStr, FileFormat:=FileFormatNum
        On Error Resume Next
        With OutMail
            .To = ""
            .CC = ""
            .BCC = ""
            .Subject = ek & " Raporudur" '"This is the Subject line"
            .Body = "Hi there"
            .Attachments.Add Destwb.FullName
            'You can add other files also like this
            '.Attachments.Add ("C:\test.txt")
            .Display   'or use .Send
        End With
        On Error GoTo 0
        .Close SaveChanges:=False
    End With
    'Delete the file you have send
    Kill TempFilePath & TempFileName & FileExtStr
    If snc <> "" Then
    End If
    Set OutMail = Nothing
    Set OutApp = Nothing
End Sub
Sub FiltreliAlanıYeniSayfaYap()
Application.ScreenUpdating = False
sfAdi = ActiveSheet.Name: snc = ""
'Çalışma Sayfasında filtre uygulanmış mı?
If ActiveSheet.FilterMode = False Then GoTo TAMAMINIGONDER
'Uygulanmışsa; süzülen kriterlerin başlıklarını ve değerlerini bulur
    Dim Suz As Variant                                   'Dizi değişkeni tanımla
    sonfiltsut = ActiveSheet.AutoFilter.Filters.Count    'Filtre uygulanmış sütun sayısı
    ReDim Suz(sonfiltsut)                                'Suz değişkenini, sonfiltsut değişkeni kadar boyutlandır
        For a = sonfiltsut To 1 Step -1                  'Son filtrelenenden ilk filtrelenene kadar döngü başlat
            If ActiveSheet.AutoFilter.Filters.Item(a).On Then       'Filtre açıksa (kulakçık mavi ise)
                c = c + 1                                           'c değerini bir artır
                stnno = ActiveSheet.AutoFilter.Range.Cells(a).Column    'Sütun nosunu bul
                strno = ActiveSheet.AutoFilter.Range.Cells(a).Row       'Satır nosunu bul
                SuzBas = ActiveSheet.AutoFilter.Range.Cells(a).Value    'Hücre değerini bul
                SuzKrt = Kriterler(Cells(strno + 1, stnno))             'Kriter değerini bul
                Suz(c) = SuzBas & ": " & SuzKrt                         'Hücre ve kriter değerlerini diziye al
                snc = Suz(c) & ", " & snc                               'snc değişkenine ata
            End If                                                      'Kontrolden çık
        Next                                                            'bir sonraki filtrelenene bak

    'Filtrelenmiş Alanı yeni sayfaya kopyalar
    Cells.Copy:        Sheets.Add                           'kopyala ve sayfa ekle, eklenen sayfada;
    Cells.PasteSpecial Paste:=xlPasteColumnWidths           'kolon genişliklerini yapıştır
    Selection.PasteSpecial Paste:=xlPasteValues             'Değerleri            yapıştır
    Selection.PasteSpecial Paste:=xlPasteFormats            'Biçimleri            yapıştır
    'ActiveSheet.Paste   'herşeyi kopyalar                  'Hepsini              yapıştır
    Application.CutCopyMode = False                         'Kopyalama Modunu Kapat
    'oluşturulan yeni sayfanının baslik, kenarlık ve yazdırma alanlarını düzenler
    sonsut = Cells(strno, 1).End(xlToRight).Column          'yeni sayfadaki son dolu sutun
                'sonsut = sonfiltsut
    sonsat = Cells(65536, 1).End(xlUp).Row                  'yeni sayfadaki son dolu satır
    Range(Cells(strno - 5, 1), Cells(strno - 5, sonsut)).Select:     Call BaslikSatiri     'Başlık satırını belirle ve biçimlendir.
    Cells(strno - 5, 1).Value = snc & " Raporudur"
    Cells.Select:                                                    Call KenarlikYok      'Belirlenen aralıktaki, kenarlıkları sil
    Range(Cells(strno, 1), Cells(sonsat, sonsut)).Select:            Call KenarlikCiz      'Belirlenen aralığa kenarlık çiz
    ActiveSheet.PageSetup.PrintArea = "$A$1:$K$" & sonsat:           Call KenarBosluk      'Sayfanın kenar boşluklarını belirle (Kağıtta)
    Cells(1, 1).Select                                      'A1 i seç
    Erase Suz
    Call AktifSayfayıPostala                              'oluşturulan sayfayı outloka ekle
    Application.DisplayAlerts = False   'ekrana mesaj vermeyi kapat
        Sheets(1).Delete
    Application.DisplayAlerts = True   'ekrana mesaj vermeyi aç
    GoTo SON
    
TAMAMINIGONDER:
    onay = MsgBox("Bu Sayfada filtre uygulanmamış!" & Chr(10) & _
    "İşleme devam ederseniz sayfanın tamamı postalanacaktır" & Chr(10) & _
    " İşleme devam etmek istiyor musunuz?", vbYesNo + vbCritical, "DİKKAT !")   'Onay Mesajı Al
    If onay = vbYes Then
        Call AktifSayfayıPostala                              'oluşturulan sayfayı outloka ekle
    ElseIf onay = vbNo Then                                                                         'devam edilmeyecekse
        Exit Sub                                                                                'makrodan çık
    End If
SON:
Application.ScreenUpdating = True
MsgBox "tamamlandı"
End Sub

Sub SeciliAlanıYeniSayfaYap()
    Selection.Copy:     Sheets.Add:     ActiveSheet.Paste
    snc = "Seçili Alan"
    Call AktifSayfayıPostala                              'oluşturulan sayfayı outloka ekle
    Application.DisplayAlerts = False   'ekrana mesaj vermeyi kapat
        Sheets(1).Delete
    Application.DisplayAlerts = True   'ekrana mesaj vermeyi aç

End Sub

Private Sub BaslikSatiri()
    With Selection
        .HorizontalAlignment = xlCenter:        .VerticalAlignment = xlBottom
        .WrapText = False:          .Orientation = 0:                   .AddIndent = False
        .IndentLevel = 0:           .ShrinkToFit = False:               .ReadingOrder = xlContext
        .MergeCells = True:         .RowHeight = 20
    End With
    With Selection.Font
        .Name = "Arial Tur":        .Size = 12:                         .Strikethrough = False
        .Superscript = False:       .Subscript = False:                 .OutlineFont = False
        .Shadow = False:            .Underline = xlUnderlineStyleNone:  .ColorIndex = xlAutomatic
        .Bold = True
    End With
End Sub

Private Sub KenarBosluk()
    With ActiveSheet.PageSetup
        .LeftMargin = Application.InchesToPoints(0.393700787401575)
        .RightMargin = Application.InchesToPoints(0.393700787401575)
        .TopMargin = Application.InchesToPoints(0.984251968503937)
        .BottomMargin = Application.InchesToPoints(0.984251968503937)
        .HeaderMargin = Application.InchesToPoints(0.511811023622047)
        .FooterMargin = Application.InchesToPoints(0.511811023622047)
        .Orientation = xlLandscape
    End With
End Sub

Private Sub KenarlikCiz()
    Selection.Borders(xlDiagonalDown).LineStyle = xlNone
    Selection.Borders(xlDiagonalUp).LineStyle = xlNone
    With Selection.Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .Weight = xlMedium
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .Weight = xlMedium
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .Weight = xlMedium
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .Weight = xlMedium
        .ColorIndex = xlAutomatic
    End With
    Selection.Borders(xlInsideVertical).LineStyle = xlNone
    Selection.Borders(xlInsideHorizontal).LineStyle = xlNone
    Selection.Borders(xlDiagonalDown).LineStyle = xlNone
    Selection.Borders(xlDiagonalUp).LineStyle = xlNone
    With Selection.Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .Weight = xlMedium
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .Weight = xlMedium
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .Weight = xlMedium
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .Weight = xlMedium
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlInsideVertical)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlInsideHorizontal)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
End Sub

Private Sub KenarlikYok()
    Selection.Borders(xlDiagonalDown).LineStyle = xlNone
    Selection.Borders(xlDiagonalUp).LineStyle = xlNone
    Selection.Borders(xlEdgeLeft).LineStyle = xlNone
    Selection.Borders(xlEdgeTop).LineStyle = xlNone
    Selection.Borders(xlEdgeBottom).LineStyle = xlNone
    Selection.Borders(xlEdgeRight).LineStyle = xlNone
    Selection.Borders(xlInsideVertical).LineStyle = xlNone
    Selection.Borders(xlInsideHorizontal).LineStyle = xlNone
End Sub
 
Son düzenleme:
merhaba hakan439 bey
kodu denedinizmi acaba şuan aynı sorunla bende karşı karşıyayım da ben en son kodu alıp yapıştırıyorum bir türlü olmuyor yardımcı olurmusunuz lütfen
 
sayın hsayar
verdiğin iki ayrı kodu excel sayfasına ekledim
ve sayfada bir buton oluşturdum butona sağ tıklayıp makro atadan " Sayfa1.FiltreliAlanıYeniSayfaYap " seçtim ardından veriyi filtreleyip butona bastığımda kriter hatası ve benzeri hataalr veriyor lütfen tam olarak ne yapmam lazım yardımcı olurmusunuz
 
Emeğe saygı güzel bir çalışma ..
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst