Tek bir sayfada çoklu yazdırma

[ASLAN7410]

Merhaba arkadaşlar.

Aşağıdaki kodu forumda buldum. Yazdırmak için işime yarayacak ancak her seferinde basmam gerekiyor.

Benim hazırlamış olduğum sayfamda ÜST YAZI sayfasının K5 hücresindeki rakama göre düşeyara ile ARŞİV sayfasındaki bilgileri getiriyorum.

Benim istediğim K5 hücresine 1 yazıp yazdır butonuna bastığımda ARŞİV sayfasının A sütünundaki son sayıya kadar otomatik olarak K5 hücresine sayılar artırarak sırası ile yazdırıp diğer sayıya geçmesini istiyorum. ARŞİV sayfasının A sütunundaki verilerin en son sayısına kadar bu işlemin devam etmesini istiyorum.

ARŞİV sayfamda yaklaşık 250'yi geçen veri var, bunları üst yazıya dökmek istiyorum, tek tek bilgileri çağırıp yazdırmak uzun zaman alıyor, tek bir seferde bütün üst yazıları sırası ile yazdırmak istiyorum.

Sub Yazdır()
Sheets("ÜST YAZI").Select
[K5] = [K5] + 1
ActiveWindow.SelectedSheets.PrintOut copies:=1, collate:=True
End Sub

Yardım edecek arkadaşlara şimdiden teşekkür ederim.

 

[Orion1]

Örnek dosya yüklerseniz daha hızlı yanıt alabilirsiniz.

 

[ASLAN7410]

Örnek dosya ekte

 

[Orion1]

Buyurun.

Sub Yazdır()
Dim sh As Worksheet, sonsat As Long, i As Long
Sheets("ÜST YAZI").Select
Set sh = Sheets("ARŞİV")
sonsat = sh.Cells(Rows.Count, "A").End(xlUp).Row
For i = 2 To sonsat
    Range("K5").Value = sh.Cells(i, "A").Value
    ActiveWindow.SelectedSheets.PrintOut copies:=1, collate:=True
Next i
End Sub

 

[ASLAN7410]

Sayın Evren Bey vardiyalı çalıştığım için yeni bilgisayar başına geçtim.

Yazmış olduğunuz kod gayet güzel çalışıyor, ellerinize sağlık, çok teşekkür ediyorum.

ARŞİV sayfasının A sütunundada 1'den 300'e kadar veri var.

Küçük bir isteğim olacak, ÜST YAZI sayfasının K5 hücresine örneğin 250 yazdığımda buradaki sayı ile başlayarak en son satıra kadar yazdırmak için kodun neresinde değişiklik yapmam gerekir.

Ayrıca yazdırma işlemi bittiğinde, en son satırdaki sayı kaç ise 300.satıra kadar yazdırıldı mesajı gelebilirmi?

 

[ASLAN7410]

Sayın Yönetici arkadaşlar yardımcı olabilir misiniz?

 

[Orion1]

Sayın Evren Bey vardiyalı çalıştığım için yeni bilgisayar başına geçtim.

Yazmış olduğunuz kod gayet güzel çalışıyor, ellerinize sağlık, çok teşekkür ediyorum.

ARŞİV sayfasının A sütunundada 1'den 300'e kadar veri var.

Küçük bir isteğim olacak, ÜST YAZI sayfasının K5 hücresine örneğin 250 yazdığımda buradaki sayı ile başlayarak en son satıra kadar yazdırmak için kodun neresinde değişiklik yapmam gerekir.

Ayrıca yazdırma işlemi bittiğinde, en son satırdaki sayı kaç ise 300.satıra kadar yazdırıldı mesajı gelebilirmi?

Buyurun.

Sub Yazdır()
Dim sh As Worksheet, sonsat As Long, i As Long
Dim k As Range
Sheets("ÜST YAZI").Select
Set sh = Sheets("ARŞİV")
sonsat = sh.Cells(Rows.Count, "A").End(xlUp).Row
Set k = sh.Range("A2:A" & sonsat).Find(Range("K5").Value, , xlValues, xlWhole)
If k Is Nothing Then
    MsgBox Range("K5").Value & vbLf & "Bu numaraya rastlanmadı.İşlem İptal oldu!", vbCritical, "UYARI"
    Exit Sub
End If
For i = k.Row To sonsat
    Range("K5").Value = sh.Cells(i, "A").Value
    ActiveWindow.SelectedSheets.PrintOut copies:=1, collate:=True
Next i
MsgBox sh.Range("A" & sonsat).Value & vbLf & "Kadar Yazdırıldı.", , "evrengizlen@hotmail.com"

End Sub

 

[ASLAN7410]

Sayın Evren Bey ellerinize sağlık Allah razı olsun, tam istediğim gibi oldu.

Hayırlı geceler, hayırlı çalışmalar.

 

[Orion1]

Sayın Evren Bey ellerinize sağlık Allah razı olsun, tam istediğim gibi oldu.

Hayırlı geceler, hayırlı çalışmalar.

Rica ederim.
İyi çalışmalar.

 

[ASLAN7410]

Sayın Evren Bey hayırlı geceler. Önceki yazmış olduğunuz bütün kodlar çok işime yaradı, çok teşekkür ediyorum.


Küçük bir istek daha doğdu.
Sayının yazdırma başlangıç hücresi K5 hücresi olsun, yazdırmanın bitiş hücresi K6 olsun.

Örnek olarak K5'e 150 yazıp, K6'ya 160 yazıp yazdır butonuna bastığımda 150 ile 160 arasını yazdırmak istiyorum. Şimdiden teşekkür ediyorum.

 

[ASLAN7410]

Sayın Evren Bey konu günceldir, yardımcı olabilir misiniz?

 

[Orion1]

Sayın Evren Bey hayırlı geceler. Önceki yazmış olduğunuz bütün kodlar çok işime yaradı, çok teşekkür ediyorum.


Küçük bir istek daha doğdu.
Sayının yazdırma başlangıç hücresi K5 hücresi olsun, yazdırmanın bitiş hücresi K6 olsun.

Örnek olarak K5'e 150 yazıp, K6'ya 160 yazıp yazdır butonuna bastığımda 150 ile 160 arasını yazdırmak istiyorum. Şimdiden teşekkür ediyorum.

Buyurun.

Sub Yazdır()
Dim sh As Worksheet, i As Long
Dim k As Range
Sheets("ÜST YAZI").Select
Set sh = Sheets("ARŞİV")
sonsat = sh.Cells(Rows.Count, "A").End(xlUp).Row
For i = Range("K5").Value To Range("K6").Value
    Set k = sh.Range("A2:A" & sonsat).Find(i, , xlValues, xlWhole)
    If Not k Is Nothing Then
        Range("B6").Value = k.Offset(0, 1).Value
        ActiveWindow.SelectedSheets.PrintOut copies:=1, collate:=True
    End If
Next i
MsgBox "Yazdırma işlemi tamamlandı.", , "evrengizlen@hotmail.com"

End Sub

 

[ASLAN7410]

Sayın Evren Bey çok teşekkür ediyorum, Allah razı olsun hayırlı geceler diliyorum.

 

[Orion1]

Sayın Evren Bey çok teşekkür ediyorum, Allah razı olsun hayırlı geceler diliyorum.

Rica ederim.
Hayırlı geceler.

 

[angloth]

Buyurun.

Sub Yazdır()
Dim sh As Worksheet, sonsat As Long, i As Long
Dim k As Range
Sheets("ÜST YAZI").Select
Set sh = Sheets("ARŞİV")
sonsat = sh.Cells(Rows.Count, "A").End(xlUp).Row
Set k = sh.Range("A2:A" & sonsat).Find(Range("K5").Value, , xlValues, xlWhole)
If k Is Nothing Then
    MsgBox Range("K5").Value & vbLf & "Bu numaraya rastlanmadı.İşlem İptal oldu!", vbCritical, "UYARI"
    Exit Sub
End If
For i = k.Row To sonsat
    Range("K5").Value = sh.Cells(i, "A").Value
    ActiveWindow.SelectedSheets.PrintOut copies:=1, collate:=True
Next i
MsgBox sh.Range("A" & sonsat).Value & vbLf & "Kadar Yazdırıldı.", , "evrengizlen@hotmail.com"

End Sub

İyi günler bu kodu kendi sayfama uyarladım. Fakat burada sizden ricam bu kodda belirtilen sayfa yazdırıldıktan sonra sayfa2 deki sayfayı da sırayla çıktı almamız mümkün mü?

Yani isteğim koddaki ilk üst yazı sayfasını yazdıracak arkasına sayfa2 yi yazdıracak ve tekrar diğer sayıyla aynı işlemi devam ettirecek.