VBA ile etiket oluşturma

[kdr20_88]

Merhaba,
Excelde VBA ile Sayfa1 sarı alandaki yazılanları Sayfa2 de aşağıya doğru Sayfa1 B3 hücresinde yazılan kadar alt alta yazdırma istiyorum. Bunu yaparken de örneğin B3 te 4 yazıyorsa Sayfa 2 de yazdırırken aşağıdaki örnekteki gibi 1/4, 2/4, 3/4, 4/4 şeklinde yazdırmaya çalışıyorum ama beceremedim.

Yardım edebilir misiniz?

 

[relaxim]

Merhaba

Aşağıdaki link belki yardımcı olur.

İrsaliye sayfasındaki verileri diğer sayfalara dağıtma

Merhabalar, irsaliye kestiğim parçalara etiket yazdırmak istiyorum. Eklediğim örnekte açıklamaya çalıştım. Şimdiden yardımcı olacaklara teşekkür ederim.

www.excel.web.tr

 

[Muzaffer Ali]

Merhaba.
Aşağıdaki kodu deneyiniz.

Sub Test()
    Dim Say As Integer
    Dim Sira As Integer
    Dim Syf1 As Worksheet
    Dim Syf2 As Worksheet
    
    Set Syf1 = Worksheets("Sayfa1")
    Set Syf2 = Worksheets("Sayfa2")
    
    Syf2.Range("A:B").ClearContents
    Sira = Syf2.Cells(Rows.Count, "A").End(xlUp).Row + 1
    For Say = 1 To Syf1.Range("B3").Value
        Syf2.Range("A" & Sira & ":B" & Sira + 2).Value = Syf1.Range("A1:B3").Value
        Syf2.Range("B" & Sira + 2) = "'" & Say & "/" & Syf1.Range("B3")
        Sira = 3 + Sira
    Next
End Sub

 

[Necdet]

Merhaba,
Bu soru sanki bana eksik gibi geldi. Sayfa1 deki veri tek kişiye ait olmayacağı hissine kapılarak kodları ona göre düzenledim.

Sub Deneme()

Dim i   As Long, _
    j   As Long, _
    s   As Integer, _
    si  As Integer

Application.ScreenUpdating = False
i = 1
j = Sayfa2.Cells(Rows.Count, "A").End(3).Row + 1
If j = 2 Then j = 1

Do
    s = Sayfa1.Cells(i + 2, "B")
    For si = 1 To s
        Sayfa1.Range("A" & i & ":B" & i + 2).Copy Sayfa2.Range("A" & j)
        With Sayfa2.Range("B" & j + 2)
            .NumberFormat = "@"
            .Value = si & " / " & s
        End With
        j = j + 3
    Next si
    i = i + 3
Loop Until Sayfa1.Cells(i, "A") = ""

Application.ScreenUpdating = True
MsgBox "İşlem Tamamlanmıştır.....", vbInformation, "Excel.web.tr"

End Sub

 

[kdr20_88]

Merhaba

Aşağıdaki link belki yardımcı olur.

İrsaliye sayfasındaki verileri diğer sayfalara dağıtma

Merhabalar, irsaliye kestiğim parçalara etiket yazdırmak istiyorum. Eklediğim örnekte açıklamaya çalıştım. Şimdiden yardımcı olacaklara teşekkür ederim.

www.excel.web.tr

Teşekkürler, inceleyeceğim.

 

[kdr20_88]

Merhaba.
Aşağıdaki kodu deneyiniz.

Sub Test()
    Dim Say As Integer
    Dim Sira As Integer
    Dim Syf1 As Worksheet
    Dim Syf2 As Worksheet
   
    Set Syf1 = Worksheets("Sayfa1")
    Set Syf2 = Worksheets("Sayfa2")
   
    Syf2.Range("A:B").ClearContents
    Sira = Syf2.Cells(Rows.Count, "A").End(xlUp).Row + 1
    For Say = 1 To Syf1.Range("B3").Value
        Syf2.Range("A" & Sira & ":B" & Sira + 2).Value = Syf1.Range("A1:B3").Value
        Syf2.Range("B" & Sira + 2) = "'" & Say & "/" & Syf1.Range("B3")
        Sira = 3 + Sira
    Next
End Sub

Muzaffer Ali bey elinize emeğinize sağlık. Çok güzel çalıştı.
Çok teşekkür ederim.

 

[kdr20_88]

Merhaba,
Bu soru sanki bana eksik gibi geldi. Sayfa1 deki veri tek kişiye ait olmayacağı hissine kapılarak kodları ona göre düzenledim.

Sub Deneme()

Dim i   As Long, _
    j   As Long, _
    s   As Integer, _
    si  As Integer

Application.ScreenUpdating = False
i = 1
j = Sayfa2.Cells(Rows.Count, "A").End(3).Row + 1
If j = 2 Then j = 1

Do
    s = Sayfa1.Cells(i + 2, "B")
    For si = 1 To s
        Sayfa1.Range("A" & i & ":B" & i + 2).Copy Sayfa2.Range("A" & j)
        With Sayfa2.Range("B" & j + 2)
            .NumberFormat = "@"
            .Value = si & " / " & s
        End With
        j = j + 3
    Next si
    i = i + 3
Loop Until Sayfa1.Cells(i, "A") = ""

Application.ScreenUpdating = True
MsgBox "İşlem Tamamlanmıştır.....", vbInformation, "Excel.web.tr"

End Sub

Necdet bey teşekkürler, çok güzel çalıştı. Fakat tek kişiye ait olma durumunu pek anlamadım ama bu haliyle işini gayet gördü.
Elinize emeğinize sağlık.

 

[Necdet]

Şöyle söyleyim,
Sayfa1 de yazdığınızdan 1 değil bir kaç veri olabilir, ben de kodları ona göre kurguladım.