Data sayfasındaki verileri etikete yazdırma

[First_Class]

Arkadaşlar Merhabalar


Öncelikle herkese hayırlı günler çalışan arkadaşlarıma hayırlı mesailer

Biliyorsunuz yıl sonu ve takvim vb gönderimi için elimde bir liste var onları hazırladığım etiket formuna bir buton yardımıyla ilgili yerlerine yazdırabilmek istiyorum
bu konuda yardımlarınızı rica ediyorum.

Örnek dosyayı ekliyorum

Şimdiden teşekkürler

 

[Necdet]

Merhaba,

Worddeki Adres Mektup Birleştirmeyi öneririm.

 

[First_Class]

Merhaba,

Worddeki Adres Mektup Birleştirmeyi öneririm.

Hocam cevabınız için teşekkür ederim forumda yaptığım aramalar içersinde bu önerinizi daha öncede yazdığınızı biliyorum. Lakin kullanımı pekte bana pratik gibi gelmedi üstelik etiket yazdırdığımız biçim bir a4 dosya olmadığı ve yapışkanlı bir form olduğu için belkide ben beceremediğimden yapamadım sizin bu konudaki çalışmanızda vardı ama kendi dosyama uyarlayacak macro bilgisi olmadığından bilen arkadaşlardan yardım talep ettim. yardımlarınızı ve bilginizi esirgemeyin lütfen

tekrar teşekkürler

 

[Korhan Ayhan]

Etiket satır sayılarınız aynı olursa aşağıdaki kodu kullanabilirsiniz.

Option Explicit
 
Sub AKTAR()
    Dim S1 As Worksheet, S2 As Worksheet
    Dim X As Long, Satir As Long, Sutun As Byte, Say As Byte
    
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    
    Set S1 = Sheets("DATA")
    Set S2 = Sheets("ETIKET")
    S2.Range("B:B,D:D").ClearContents
    Satir = 1
    Sutun = 2
    Say = 1
    
    For X = 2 To S1.Cells(Rows.Count, 1).End(3).Row
        If S1.Cells(X, 2) <> "" Then
            S2.Cells(Satir, Sutun) = S1.Cells(X, 2)
            S2.Cells(Satir + 1, Sutun) = S1.Cells(X, 3)
            S2.Cells(Satir + 3, Sutun) = S1.Cells(X, 4)
            S2.Cells(Satir + 5, Sutun) = S1.Cells(X, 5)
            S2.Cells(Satir + 6, Sutun) = S1.Cells(X, 6)
            Say = Say + 1
            If Sutun = 2 Then
                Sutun = 4
            Else
                Sutun = 2
                Satir = Satir + 8
            End If
            If Say = 13 And Sutun = 2 Then
                Say = 1
                Satir = Satir - 1
            End If
        End If
    Next
    
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
    
    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub

 

[First_Class]

Çok Çok teşekkürler korhan hocam elinize sağlık allah razı olsun.