sırayla yazdırma

[cem116]

Üstadlar merhaba. Bir konuda desteğe ihtiyacım var. Forumda aradığım ama aradığımı tam olarak bulamadığım bir durum için. Ekteki örnek dosyamda iki sayfam var, 1.sayfada öğrenci listem 2.sayfada da yazdırmak istediğim bir şablon var. 1.sayfadaki öğrenci listesinden öğrenci isimlerini sırayla sayfa ikiye taşıyıp sonra o sayfayı yazdıracak ve bu işlemi listedeki öğrencilerin tamamı için otomatik olarak yapacak bir çözüm arıyorum. Umarım şuan sayfada bana yardım edebilecek birileri vardır. Şimdiden çok teşekkürler.

 

[ÖmerBey]

Merhaba,
Aşağıdaki kodları kullanabilirsiniz. A sütununda "ü" yazan (tik işareti olan) satırı yazdırır. A sütunu hızlı işlem için ilk hücreye yazıp aşağı çekerek çoğaltınız.
Bir de hazırladığınız dosyada uzun isimler tam çıkmayacaktır o yüzden sayfa1 deki hücre biçimini hizalama sekmesinden uyacak şekilde daralt şeklinde düzenleyemeniz daha uygun olacaktır.

Sub kod()
Dim s1 As Worksheet, s2 As Worksheet
Dim sat As Byte, süt As Byte
Dim a As Integer
Set s1 = Sheets("öğrenci")
Set s2 = Sheets("Sayfa1")
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
s2.Unprotect
s2.Cells.ClearContents
sat = 4
süt = 1
For a = 2 To s1.Range("A65500").End(3).Row
    If s1.Cells(a, "A").Value = "ü" Then
        s2.Cells(sat, süt) = "CUMHURİYET ORTAOKULU"
        s2.Cells(sat + 1, süt) = s1.Cells(a, "B")
        s2.Cells(sat + 2, süt + 1) = s1.Cells(a, "C")
        süt = süt + 4
    End If
    If süt > 13 Then
        sat = sat + 6
        süt = 1
        If sat > 46 Then
            s2.PrintOut
            s2.Cells.ClearContents
            sat = 4
        End If
    End If
Next
If sat <> 1 And süt <> 4 Then s2.PrintOut
s2.Protect
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
MsgBox "İşlem tamamlandı."
End Sub

İyi çalışmalar...

 

[cem116]

Öncelikle yanıtınız ve yardımınız için çok teşekkürler ÖmerBey . Gün içinde, cevap yazdığınızı gelen maille ve sayfaya sadece mesajınıza bakmak için girerek gördüm, ancak iş yoğunluğundan ancak şimdi kodu deneme ve cevap yazma imkanı buldum bu nedenle kusura bakmayın. Yazdığınız kod gayet doğru ve sorunsuz çalışıyor gördüğüm kadarıyla. Ancak bir küçük problem var ve anladığım kadarıyla bu benim ekteki dosyada yaptığım açıklamada bir hususu atlamış olmamdan kaynaklanıyor. Şöyle ki etiket yazdırırken asıl amaçladığımız şey, tek bir ismi sayfadaki tüm etiketlere yazdırmak. Yani bir öğrencinin ismi sayfada etiket alanı olarak belirlediğimiz tüm kısımlarda yazacak. böylece bir isim için 32 etiket basmış olacağız. Bu işlemi de her öğrenci için tekrar edeceğiz. Ben bu nedenle sayfa1 de a5 ve b6 hücrelerine yazılan ismin tüm sayfada ilgili yerlere gelecek şekilde formülle düzenlemesini yapmıştım ama açıklamayı eksik yaptığımı şimdi anlıyorum Dosyayı gerekli açıklamayı da ekleyerek yeniden yüklüyorum. ÖmerBey ve yardımcı olabilecek arkadaşlara şimdiden çok teşekkürler. Dosyamız ektedir.

http://www.dosya.tc/server15/utvv7j/etiket_yazdirma.rar.html

 

[ÖmerBey]

Tekrar merhaba, deneyiniz...

Sub kod()
Dim s1 As Worksheet, s2 As Worksheet
Dim okul As Range, isim As Range, sinif As Range
Dim a As Integer

Set s1 = Sheets("öğrenci")
Set s2 = Sheets("Sayfa1")
Set okul = s2.Range("A4, E4, I4, M4, A10, E10, I10, M10, A16, E16, I16, M16, A22, E22, I22, M22, A28, E28, I28, M28, A34, E34, I34, M34, A40, E40, I40, M40, A46, E46, I46, M46")
Set isim = s2.Range("A5, E5, I5, M5, A11, E11, I11, M11, A17, E17, I17, M17, A23, E23, I23, M23, A29, E29, I29, M29, A35, E35, I35, M35, A41, E41, I41, M41, A47, E47, I47, M47")
Set sinif = s2.Range("B6, F6, J6, N6, B12, F12, J12, N12, B18, F18, J18, N18, B24, F24, J24, N24, B30, F30, J30, N30, B36, F36, J36, N36, B42, F42, J42, N42, B48, F48, J48, N48")

Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
s2.Unprotect
For a = 2 To s1.Range("A65500").End(3).Row
     If s1.Cells(a, "A").Value = "ü" Then
        s2.Cells.ClearContents
        okul.Value = "CUMHURİYET ORTAOKULU"
        isim.Value = s1.Cells(a, "B")
        sinif.Value = s1.Cells(a, "C")
        s2.PrintOut
    End If
Next
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
MsgBox "İşlem tamamlandı."
End Sub

 

[cem116]

ÖmerBey elinize kolunuza sağlık Gayet güzel hızlı ve sorunsuz çalışıyor. Desteğiniz için çok teşekkürler Ne söylesem az O yüzden fazla uzatmadan tekrar teşekkür ederek, iyi günler diliyorum.

 

[ÖmerBey]

Rica ederim.
İyi günler, iyi çalışmalar...