Yazdırma Butonu Destek

[mugurlu3428]

Merhabalar,

Ofiste kullanmak üzere belirli ölçülerdeki etiketlerimizde kullanmak için ek'teki excel şablonunu hazırladık.
Tasarım kısmı etiketin çıktı alınacağı şablon sayfasıdır.
Kaynak kısmına ise etiketin üzerinde yer alacak bilgiler girilmektedir.
Yapmak istediğimiz kaynak kısmına girilen her satırı otomatiik olarak şablona yerleştirsin ve print edebilsin. Şuanda sadece girilen ilk 11 kaydı çıktı alabilmektedir. Yardımlarınız için şimdiden teşekkür ederim.
Saygılarımla.

 

[ÖmerBey]

Merhaba,
Örnek dosyanız için aşağıdaki kodu boş bir modüle kopyalayıp çalıştırınız.
İyi çalışmalar...

Sub Etiket()
Dim K As Worksheet, T As Worksheet
Dim a As Long, b As Byte
Set K = Sheets("KAYNAK")
Set T = Sheets("TASARIM")
onay = MsgBox("Daha sonra çıktı almak için PDF olarak kaydetmek ister misiniz?" & vbLf & vbLf & _
            "EVET   : Masaüstü/Etiket konumuna PDF olarak kaydet" & vbLf & _
            "HAYIR  : Doğrudan aktif yazıcıdan çıktı al." & vbLf & _
            "İPTAL  : İşlemi iptal et", vbYesNoCancel)
If onay = vbCancel Then Exit Sub
T.PageSetup.PrintArea = "$A$1:$F$34"
For a = 1 To K.Cells(Rows.Count, "A").End(3).Row Step 11
    T.Range("B3:B34").ClearContents
    For b = 1 To 11
        T.Cells(b * 3, "B") = K.Cells(a + b - 1, "B")
        T.Cells(b * 3 + 1, "B") = K.Cells(a + b - 1, "A")
    Next
    isim = K.Cells(a, "A") & "_" & K.Cells(a + b - 2, "A")
    If onay = vbYes Then
        PdfKaydet (isim)
    ElseIf onay = vbNo Then
        T.PrintOut
    End If
Next
MsgBox "İşlem tamamlandı."
End Sub
Private Sub PdfKaydet(isim As String)
yol = CreateObject("WScript.Shell").SpecialFolders("Desktop") & "\Etiket"
If CreateObject("Scripting.FileSystemObject").FolderExists(yol) = False Then MkDir (yol)
Sheets("TASARIM").ExportAsFixedFormat Type:=xlTypePDF, _
            Filename:=yol & "\" & isim & ".pdf", OpenAfterPublish:=False
End Sub

 

[mugurlu3428]

Teşekkür ederim, deneyim dönüş sağlayacağım

Merhaba,
Örnek dosyanız için aşağıdaki kodu boş bir modüle kopyalayıp çalıştırınız.
İyi çalışmalar...

Sub Etiket()
Dim K As Worksheet, T As Worksheet
Dim a As Long, b As Byte
Set K = Sheets("KAYNAK")
Set T = Sheets("TASARIM")
onay = MsgBox("Daha sonra çıktı almak için PDF olarak kaydetmek ister misiniz?" & vbLf & vbLf & _
            "EVET   : Masaüstü/Etiket konumuna PDF olarak kaydet" & vbLf & _
            "HAYIR  : Doğrudan aktif yazıcıdan çıktı al." & vbLf & _
            "İPTAL  : İşlemi iptal et", vbYesNoCancel)
If onay = vbCancel Then Exit Sub
T.PageSetup.PrintArea = "$A$1:$F$34"
For a = 1 To K.Cells(Rows.Count, "A").End(3).Row Step 11
    T.Range("B3:B34").ClearContents
    For b = 1 To 11
        T.Cells(b * 3, "B") = K.Cells(a + b - 1, "B")
        T.Cells(b * 3 + 1, "B") = K.Cells(a + b - 1, "A")
    Next
    isim = K.Cells(a, "A") & "_" & K.Cells(a + b - 2, "A")
    If onay = vbYes Then
        PdfKaydet (isim)
    ElseIf onay = vbNo Then
        T.PrintOut
    End If
Next
MsgBox "İşlem tamamlandı."
End Sub
Private Sub PdfKaydet(isim As String)
yol = CreateObject("WScript.Shell").SpecialFolders("Desktop") & "\Etiket"
If CreateObject("Scripting.FileSystemObject").FolderExists(yol) = False Then MkDir (yol)
Sheets("TASARIM").ExportAsFixedFormat Type:=xlTypePDF, _
            Filename:=yol & "\" & isim & ".pdf", OpenAfterPublish:=False
End Sub