1000 adet mektup adresi yazmak

[musculus]

1000 adet mektup adresim mevcut
sayfa 1 de a sutununa isimleri, b sutununa ise adresleri yazıyorum
listele butonuna basınca döngü başlıyor

sayfa 2'ye 1.isim ve 1 .adres geliyor ve printout komutu
daha sonra 2.isim ve 2.adres yine printout komutu

fakat çıktılarım boş çıkıyor
sorunu bulamadım
dosya ektedir

 

[Mehmet Şahin]

Merhaba,
kodlarınızı biraz değiştirdim. İyi çalışmalar.

Sub yazdır()
Dim s1 As Worksheet
Dim s2 As Worksheet
Set s1 = Sheets("sayfa1")
Set s2 = Sheets("sayfa2")
son = s1.[a65535].End(3).Row
Application.ScreenUpdating = False
    With s2.PageSetup
        .PrintArea = "$A$1:$E$11"
        .PrintTitleRows = ""
        .PrintTitleColumns = ""
        .LeftHeader = ""
        .CenterHeader = ""
        .RightHeader = ""
        .LeftFooter = ""
        .CenterFooter = ""
        .RightFooter = ""
        .LeftMargin = Application.InchesToPoints(0.75)
        .RightMargin = Application.InchesToPoints(0.75)
        .TopMargin = Application.InchesToPoints(1)
        .BottomMargin = Application.InchesToPoints(1)
        .HeaderMargin = Application.InchesToPoints(0.5)
        .FooterMargin = Application.InchesToPoints(0.5)
        .PrintHeadings = False
        .PrintGridlines = False
        .PrintComments = xlPrintNoComments
        .CenterHorizontally = False
        .CenterVertically = False
        .Orientation = xlLandscape
        .Draft = False
        .PaperSize = xlPaperEnvelope10
        .FirstPageNumber = xlAutomatic
        .Order = xlDownThenOver
        .BlackAndWhite = False
        .Zoom = 100
        .PrintErrors = xlPrintErrorsDisplayed
    End With
'TextBox1.Value = UCase(Replace(Replace(TextBox1.Value, "i", "İ"), "ı", "I"))
For a = 2 To son
s2.Range("a2").Value = UCase(Replace(Replace(s1.Range("a" & a).Value, "i", "İ"), "ı", "I"))
s2.Range("a3").Value = s1.Range("b" & a).Value
s2.PrintOut
Next
s1.Select
Set s1 = Nothing: Set s2 = Nothing
Application.ScreenUpdating = True
End Sub

 

[Necdet]

Merhaba,

Aşağıdaki kodları dener misiniz?

Sub yazdır()
 
    Dim i  As Long, _
        s1 As Worksheet, _
        s2 As Worksheet
        
    Set s1 = Sheets("Sayfa1")
    Set s2 = Sheets("Sayfa2")
    
    s1.Select
    For i = 2 To Cells(Rows.Count, "A").End(3).Row
        s2.Cells(2, "A") = Cells(i, "A")
        s2.Cells(3, "A") = Cells(i, "B")
        s2.PrintOut
    Next i
 
End Sub

 

[Mahir64]

Merhaba
Mevcut örnek dosyanızda sorun yok gibi, denediğimde yazıcıdan çıktı alınıyor.

 

[musculus]

Ellerinize bilgilerinize sağlık.Yazı sola dayalı ve yarım çıktı.Ama hepsi çıktı.Yazıcı ayarlarından a5 yapınca sorunum düzeldi.Tekrar teşekkür ederim.

 

[musculus]

Merhaba
Mevcut örnek dosyanızda sorun yok gibi, denediğimde yazıcıdan çıktı alınıyor.

Bende çıktı alınıyor ama boş çıktı alınıyor idi.Ama sorunum düzeldi.İlgilenen herkese teşekkür ederim.

 

[assenucler]

Emek ve katkı veren değerli hocalarıma teşekkürler..