hücre değerine göre sayfa yazdırma

[mkarakas_58]

Merhaba arkadaşlar şimdi sayfadaki onay kutusundaki tik işaretli olanların sayfasını yazdırma ve pdf kaydetme makrosu yapmak istiyorum ama nasıl yapacağımı bilemedim. Ekte örnek vardır bana yardımcı olursanız sevinirim.


deneme.rar - 11 KB

 

[mkarakas_58]

Arkadaşlar yok mu yardım edecek üstad. Hücredeki ifadelere çalişma kitabındaki saffaları yazdırmak istiyorum.

 

[Ömer BARAN]

Merhaba.

Belge ekte.
Belgeye buradan da erişebilirsiniz.

Sonradan ilave not: (Sayın ÇOBAN'a dikkati için teşekkürler.)
Eklediğim belgede J1 ve J2 hücrelerindeki metinler ilgili sayfa adlarıyla birebir aynı olmalıdır.
Belgeyi indirdiğinizde bunları düzeltiniz.
.

 

[Emir Hüseyin Çoban]

. . .

J sütunundaki veriler, sayfa isimleriyle birebir aynı olmalı...
Bu şekli ile yazdırmaz...

Ekran Görüntüsü:


. . .

 

[Ömer BARAN]

J sütunundaki veriler, sayfa isimleriyle birebir aynı olmalı....

Merhaba Sayın ÇOBAN. Dikkatiniz için teşekkürler.
Önceki cevabıma ilave açıklama ekledim.
.

 

[mkarakas_58]

Teşekkür ederim ilginiz için ama çalışmadı makro;

Sub YAZDIR()
Set s1 = Sheets("Sayfa1"): yol = ActiveWorkbook.Path
If s1.Cells(1, "K") <> "EVET" And s1.Cells(2, "K") <> "EVET" Then
MsgBox "Sayfa adlarından hiçbiri için EVET seçeneği seçili değil!.." & vbLf & _
"Herhangi bir sayfa yazdırılmayacak."
Exit Sub
End If
For satır = 1 To 2
If s1.Cells(satır, "K") = "EVET" Then
s1.Cells(satır, "K") = "": s1.Cells(satır, "K").Activate
Sheets(s1.Cells(satır, "J").Text).PrintOut
MsgBox s1.Cells(satır, "J").Text & _
" adlı sayfa yazdırıldı...", vbInformation, "Ö.BARAN"
End If
Next
End Sub


kalın yazan kodlarda hata veriyor.

 

[Ömer BARAN]

Belge eklediğim cevaptaki, "Sonradan ilave not" kısmını tekrar okuyunuz.

 

[PLİNT]

Merhaba
Alternatif olarak bir dosya hazırlamıştım
denerseniz ektedir
http://s3.dosya.tc/server10/i3f4h2/deneme.zip.html

 

[mkarakas_58]

Ömer bey,

ilginiz ve yardımınız için çok teşekkür ederim gözümden kaçmış. Sorun yok. Teşekkür ederim.

 

[mkarakas_58]

Merhaba
Alternatif olarak bir dosya hazırlamıştım
denerseniz ektedir
http://s3.dosya.tc/server10/i3f4h2/deneme.zip.html

Teşekkür ederim hocam. Sizinkinde PDF makrosu yok. size zahmet onu nasıl hallederiz.

 

[PLİNT]

Teşekkür ederim hocam. Sizinkinde PDF makrosu yok. size zahmet onu nasıl hallederiz.

Burada dikkat etmeniz gereken örnekteki gibi
"Checkbox" ların "I" sütununa yerleşimi ve "TextFrame" lerinde sayfa adlarının hatasız yazılı olmasıdır.
Buyrun;
PDF:

[SIZE="2"]Sub Düğme6_Tıklat()
Set s1 = Sheets("Sayfa1"): yol = ActiveWorkbook.Path
For Each x In ActiveSheet.Shapes
If Not Intersect(x.TopLeftCell, Range("I1:I25")) Is Nothing Then
If ActiveSheet.Shapes(x.Name).ControlFormat.Value = xlOn Then
m = ActiveSheet.Shapes.Range(x.Name).TextFrame.Characters.Text
Sheets(Trim(m)).ExportAsFixedFormat Type:=xlTypePDF, Filename:= _
yol & "\" & m, Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, _
OpenAfterPublish:=False
MsgBox m & " adlı sayfa PDF Olarak dosyanızın yanına kaydedildi..."
End If
End If
Next
If m = Empty Then MsgBox "PDF KAYDETMEK İSTEDİĞİNİZ SAYFALARI İŞARETLEYİNİZ"
End Sub[/SIZE]

Yazdır:

 [SIZE="2"]Sub Düğme5_Tıklat()
Set s1 = Sheets("Sayfa1")
For Each x In ActiveSheet.Shapes
If Not Intersect(x.TopLeftCell, Range("I1:I25")) Is Nothing Then
If ActiveSheet.Shapes(x.Name).ControlFormat.Value = xlOn Then
m = ActiveSheet.Shapes.Range(x.Name).TextFrame.Characters.Text
Sheets(Trim(m)).PrintOut
MsgBox m & " adlı sayfa yazdırıldı..."
End If
End If
Next
If m = Empty Then MsgBox "YAZDIRILACAK SAYFA BULUNAMADI" & vbCrLf & "YAZDIRILACAK SAYFALARI İŞARETLEYİNİZ"
End Sub[/SIZE]

 

[mkarakas_58]

tEŞEKKÜR EDERİM SAĞOLUN. ÇOK İŞİME YARADI

 

[Korhan Ayhan]

Klavyenizde sorun mu var?

Forum Kuralları;

Büyük Harf Kısıtlaması:
- Mesaj yazarken büyük harf kullanmak bağırmak anlamına geleceği için yazılarınızı kesinlikle büyük harf kullanarak yazmayınız.