Auto Filter (Defination Name) to PDF

[cheeytan]

Oncelikle Selamlar,
Yardim isteyecegim konu benim icin onemli ve aciliyeti var. Ilginiz icin simdiden tesekkur ederim.
Ekte gondermis oldugum deneme.xlsx dosyasinda;

Kirmizi Ile isaretli alandaki harf secildiginde, B kolonunda otomatik olarak karsiliginda "1" yaziyor.
"1" olan degerleri sozdurup tablomu PDF yapmak istiyorum.
Ama a harfinden f harfine kadar olanlari (a-b-c-d-e-f) tek seferde sira ile kendisi suzecek ve ayri ayri belirledigim klasore PDF yapacak. (Bunu istememdeki amac suzulecek listemin bir hayli fazla olmasi)

 

[Ömer]

Merhaba,

Module kopyalarak çalıştırınız.

Sub PdfKaydet()
 
    Dim S2 As Worksheet, i As Long, dosya As String
 
    Set S2 = Sheets("Sheet2")
    Application.ScreenUpdating = False
    S2.Select
    Cells.Clear
 
    With Sheets("Sheet1")
        For i = 5 To .Cells(Rows.Count, "D").End(xlUp).Row
            .Range("D" & i, "E" & i).Copy Range("A1")
 
            dosya = CreateObject("Wscript.Shell").SpecialFolders.Item("Desktop") & _
            "\Dosya" & Application.PathSeparator & .Value & ".pdf"
 
            ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:= _
                dosya, Quality:= _
                xlQualityStandard, IncludeDocProperties:=False, IgnorePrintAreas:=False, _
                OpenAfterPublish:=False
        Next i
        Cells.Clear
        .[D3].Select
    End With
    Application.ScreenUpdating = True
 
End Sub

Not: 2007 ve üst versiyonlarda çalışır.

.

 

[cheeytan]

Sanirim sordugum soruyu tam anlatamadim. Ben filitre (defination name) sira ile kendisi secip, otomatik belirledigim klasorun icine PDF olarak kaydetmesini istiyorum. Bu yapmis oldugunuzu calistirdigimda sadece sheet2'ye suzdurulmus olani aliyor.

 

[cheeytan]

...

Merhaba,

Module kopyalarak çalıştırınız.

Sub PdfKaydet()
 
    Dim S2 As Worksheet, i As Long, dosya As String
 
    Set S2 = Sheets("Sheet2")
    Application.ScreenUpdating = False
    S2.Select
    Cells.Clear
 
    With Sheets("Sheet1")
        For i = 5 To .Cells(Rows.Count, "D").End(xlUp).Row
            .Range("D" & i, "E" & i).Copy Range("A1")
 
            dosya = CreateObject("Wscript.Shell").SpecialFolders.Item("Desktop") & _
            "\Dosya" & Application.PathSeparator & .Value & ".pdf"
 
            ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:= _
                dosya, Quality:= _
                xlQualityStandard, IncludeDocProperties:=False, IgnorePrintAreas:=False, _
                OpenAfterPublish:=False
        Next i
        Cells.Clear
        .[D3].Select
    End With
    Application.ScreenUpdating = True
 
End Sub

Not: 2007 ve üst versiyonlarda çalışır.

.

-----------------


Sanirim sordugum soruyu tam anlatamadim. Ben filitre (defination name) sira ile kendisi secip (suzun en basindankinden en sonuna kadar), otomatik belirledigim klasorun icine PDF olarak kaydetmesini istiyorum. Bu yapmis oldugunuzu calistirdigimda sadece sheet2'ye suzdurulmus olani aliyor.

Yani suz - fakli kaydet (PDF) her suzdurne icin. Bende yaklasik suzdurecegi liste 1000 civari. Yani 1000 Adet farkli PDF dosyasi elde etmeye calisiyorum tek seferde.

Office 2010 Kullaniyorum.

 

[Ömer]

Bu şekilde deneyiniz. Doğrulamanın içinde döngü kurmak yerine doğrulamayı aldığınız alana döngü kurdum. Eğer illaki doğrulamanın içine kurulacaksa ona göre yeniden düzenlerim.

Masa üstünde Dosya adlı klasör oluşturduğunuz düşünülmüştür.

Sub PdfKaydet()
 
    Dim i As Long, [COLOR=black]dosya[/COLOR] As String, sonL As Long
 
    Application.ScreenUpdating = False
 
    ActiveSheet.AutoFilterMode = False
    sonL = Cells(Rows.Count, "D").End(xlUp).Row
    Range("D4:E" & sonL).AutoFilter
 
    For i = 5 To Cells(Rows.Count, "L").End(xlUp).Row
 
        Range("D4").AutoFilter Field:=1, Criteria1:=Cells(i, "L")
 
        [COLOR=black]dosya[/COLOR] = CreateObject("Wscript.Shell").SpecialFolders.Item("Desktop") & _
        "\[COLOR=red]Dosya[/COLOR]" & Application.PathSeparator & Cells(i, "L") & ".pdf"
 
        ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:= _
       [COLOR=black] dosya[/COLOR], Quality:= _
            xlQualityStandard, IncludeDocProperties:=False, IgnorePrintAreas:=False, _
            OpenAfterPublish:=False
    Next i
 
    ActiveSheet.AutoFilterMode = False
    Application.ScreenUpdating = True
 
End Sub

.

 

[Korhan Ayhan]

Merhaba,

Bede bir kod hazırlamıştım. Alternatif olarak değerlendirirsiniz.

Kod masaüstünüze "PDF_DOSYALARI" adında bir klasör oluşturur ve pdf dosyalarını bu klasöre kayıt eder.

Option Explicit
 
Sub PDF_KAYDET()
    Dim S1 As Worksheet, S2 As Worksheet, X As Integer
    Dim Dosya_Yolu As String, Dosya_Sistemi As Object
 
    Application.ScreenUpdating = False
 
    Dosya_Yolu = CreateObject("Wscript.Shell").SpecialFolders.Item("Desktop") & "\PDF_DOSYALARI\"
 
    Set Dosya_Sistemi = CreateObject("Scripting.FileSystemObject")
 
    If Not Dosya_Sistemi.FolderExists(Dosya_Yolu) Then
        Dosya_Sistemi.CreateFolder (Dosya_Yolu)
    End If
 
    Set S1 = Sheets("Sheet1")
    Set S2 = Sheets("Sheet2")
    S2.Cells.Delete
 
    For X = 5 To S1.Cells(Rows.Count, "L").End(3).Row
        S1.Range("D3") = S1.Cells(X, "L")
        S1.Range("B4:B" & Rows.Count).AutoFilter Field:=1, Criteria1:="1"
        S1.Range("D5:E" & S1.Cells(Rows.Count, "E").End(3).Row).Copy S2.Range("A1")
 
        S2.ExportAsFixedFormat Type:=xlTypePDF, _
        Filename:=Dosya_Yolu & S1.Range("D3") & ".pdf" _
        , Quality:=xlQualityStandard, _
        IncludeDocProperties:=True, _
        IgnorePrintAreas:=False, _
        OpenAfterPublish:=False
 
        S2.Cells.Delete
    Next
 
    S1.Range("B4").AutoFilter
 
    Set Dosya_Sistemi = Nothing
    Set S1 = Nothing
    Set S2 = Nothing
 
    Application.ScreenUpdating = True
 
    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
 
    CreateObject("Shell.Application").Open (Dosya_Yolu)
End Sub

 

[cheeytan]

Tesekkur Ederim.

Cok Tesekkur Ederim. Gonderdiginiz Kod isime yaradi. Allah Razi Olsun.