Hücre iceriğine göre yazdırma

[mesutaygun70]

Öncelikle herkese teşekkürler. Birçok şey öğrendim buradan. Yine birşeyin içinden çıkamadım. Forumda aradım fakat uyarlayamadım.
http://s4.dosya.tc/server3/8zzkge/ORNEK.xlsx.html
dosyada olduğu gibi sayfa4 de d sutununda seçili hücre yazdır ise sadece karşılığında olan sayfaları butona basınca yazdırsın istiyorum. Teşekkürler.

 

[asi_kral]

Merhaba
Sayfanın kod bölümüne kopyalayın ve deneyin.

Option Explicit
Private Sub CommandButton1_Click()
Dim STR As Long
For STR = 1 To Cells(Rows.Count, "D").End(xlUp).Row
If WorksheetFunction.Proper(Cells(STR, "D")) = "Yazdır" Then
Sheets(Cells(STR, "C").Text).PrintOut
End If: Next
End Sub

 

[YUSUF44]

Aşağıdaki kodları kullanabilirsiniz:

Sub yazdır()
son = Cells(Rows.Count, "C").End(3).Row
For i = 1 To son
    If Cells(i, "D") = "YAZDIR" Then
        sayfa = Cells(i, "C").Value
        Sheets(sayfa).PrintOut
    End If
Next
End Sub

 

[askm]

Private Sub CommandButton1_Click()
For i = 1 To Cells(Rows.Count, "c").End(xlUp).Row
    If Cells(i, 4) = "YAZDIR" Then
        Sheets(Cells(i, 3).Text).PrintOut
    End If
Next
End Sub

 

[mesutaygun70]

Teşekkürler. Özelliklede hızınız için ama yine bir sorunum var aynı işlemi pdf yaparken uyarlayamadım. Yardımlarınızı bekliyorum. dosya aşağıdadır butona basınca pdf olarak tümünü yapıyor (bilgisayar yolunu belirtin) ama ben sadece d sutundaki veriye göre yapmak istiyorum.

 

[askm]

Dosya eklemeyi unutmuşsunuz.

 

[asi_kral]

Teşekkürler. Özelliklede hızınız için ama yine bir sorunum var aynı işlemi pdf yaparken uyarlayamadım. Yardımlarınızı bekliyorum. dosya aşağıdadır butona basınca pdf olarak tümünü yapıyor (bilgisayar yolunu belirtin) ama ben sadece d sutundaki veriye göre yapmak istiyorum.

Merhaba
Kodu bununla değiştirin.

Option Explicit
Private Sub CommandButton1_Click()
Dim STR As Long, SYF As Worksheet
For STR = 1 To Cells(Rows.Count, "D").End(xlUp).Row
If WorksheetFunction.Proper(Cells(STR, "D")) = "Yazdır" Then
Set SYF = Sheets(Cells(STR, "C").Text)
SYF.PrintOut
SYF.ExportAsFixedFormat xlTypePDF, [COLOR="Red"]ThisWorkbook.Path[/COLOR] & "\" & Replace(ActiveWorkbook.Name, ".xlsx", "") & " " & SYF.Name & ".pdf"
End If: Next
End Sub

Dosya nerede ise oraya pdf dosyası oluşturur.
Kırmızı yazan yere siz dilediğiniz yolu yazabilirsiniz ?

 

[mesutaygun70]

http://s4.dosya.tc/server3/h06ef3/ORNEKPDF.rar.html

 

[askm]

Private Sub CommandButton1_Click()
Dim STR As Long, SYF As Worksheet

For i = 1 To Cells(Rows.Count, "c").End(xlUp).Row
    If Cells(i, 4) = "PDF" Then
        Set SYF = Sheets(Cells(i, 3).Text)
        SYF.ExportAsFixedFormat xlTypePDF, ThisWorkbook.Path & "\" & Replace(ActiveWorkbook.Name, ".xlsx", "") & " " & SYF.Name & ".pdf"
    End If
Next
End Sub

 

[mesutaygun70]

İki pdf dosyasının tek dosyada birleşmesi gerekiyor

 

[askm]

Aşağıdaki gibi deneyin.

Sub Sayfalari_Pdf_Yap()
 
    Dim i As Integer
    Dim j As Integer
    Dim s()
    
For i = 1 To Sayfa1.Cells(Rows.Count, "c").End(xlUp).Row
    
        If Sayfa1.Cells(i, 4) = "PDF" Then
        
            ReDim Preserve s(j)
            s(j) = Sheets(Sayfa1.Cells(i, 3).Text).Name
            Sheets(Sayfa1.Cells(i, 3).Text).PageSetup.PrintArea = Range("a1:I45").Address
            j = j + 1
        End If
    Next i
 
    Sheets(s).Select
 
 ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:= _
    ThisWorkbook.Path & "\" & Replace(ActiveWorkbook.Name, ".xlsm", "") & " " & Format(Now, "dd.mm.yyyy hh mm") & ".pdf", Quality:=xlQualityStandard, _
    IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False
Sheets("Sayfa4").Select
End Sub