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

[relaxim]

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.

 

[relaxim]

Güncel...

 

[relaxim]

Günceldir...Saygılar...

 

[YUSUF44]

Aşağıdaki makroyu deneyiniz:

Sub Düğme1_Tıklat()
Application.ScreenUpdating = False
Set irs = Sheets("İRSALİYE")
Set s1 = Sheets("ETKT1")
Set s2 = Sheets("ETKT2")
Set s3 = Sheets("ETKT3")
a = 0
For etkt1 = 11 To 20 Step 2
    If irs.Cells(etkt1, "A") <> "" Then
        s1.Cells((etkt1 - 11) * 5 + 2, "B") = irs.[F4]
        s1.Cells((etkt1 - 11) * 5 + 3, "B") = irs.[F6]
        s1.Cells((etkt1 - 11) * 5 + 4, "B") = irs.Cells(etkt1, "E")
        s1.Cells((etkt1 - 11) * 5 + 5, "B") = irs.Cells(etkt1, "F")
        s1.Cells((etkt1 - 11) * 5 + 6, "B") = irs.Cells(etkt1, "A")
        s1.Cells((etkt1 - 11) * 5 + 7, "B") = irs.Cells(etkt1, "B")
        s1.Cells((etkt1 - 11) * 5 + 8, "B") = irs.Cells(etkt1, "C")
        a = a + 1
    Else
        s1.Cells((etkt1 - 11) * 5 + 2, "B").ClearContents
        s1.Cells((etkt1 - 11) * 5 + 3, "B").ClearContents
        s1.Cells((etkt1 - 11) * 5 + 4, "B").ClearContents
        s1.Cells((etkt1 - 11) * 5 + 5, "B").ClearContents
        s1.Cells((etkt1 - 11) * 5 + 6, "B").ClearContents
        s1.Cells((etkt1 - 11) * 5 + 7, "B").ClearContents
        s1.Cells((etkt1 - 11) * 5 + 8, "B").ClearContents
    End If
    
    If irs.Cells(etkt1 + 1, "A") <> "" Then
        s1.Cells((etkt1 - 11) * 5 + 2, "E") = irs.[F4]
        s1.Cells((etkt1 - 11) * 5 + 3, "E") = irs.[F6]
        s1.Cells((etkt1 - 11) * 5 + 4, "E") = irs.Cells(etkt1 + 1, "E")
        s1.Cells((etkt1 - 11) * 5 + 5, "E") = irs.Cells(etkt1 + 1, "F")
        s1.Cells((etkt1 - 11) * 5 + 6, "E") = irs.Cells(etkt1 + 1, "A")
        s1.Cells((etkt1 - 11) * 5 + 7, "E") = irs.Cells(etkt1 + 1, "B")
        s1.Cells((etkt1 - 11) * 5 + 8, "E") = irs.Cells(etkt1 + 1, "C")
        a = a + 1
    Else
        s1.Cells((etkt1 - 11) * 5 + 2, "E").ClearContents
        s1.Cells((etkt1 - 11) * 5 + 3, "E").ClearContents
        s1.Cells((etkt1 - 11) * 5 + 4, "E").ClearContents
        s1.Cells((etkt1 - 11) * 5 + 5, "E").ClearContents
        s1.Cells((etkt1 - 11) * 5 + 6, "E").ClearContents
        s1.Cells((etkt1 - 11) * 5 + 7, "E").ClearContents
        s1.Cells((etkt1 - 11) * 5 + 8, "E").ClearContents
    End If
Next

For etkt2 = 21 To 30 Step 2
    If irs.Cells(etkt2, "A") <> "" Then
        s2.Cells((etkt2 - 21) * 5 + 2, "B") = irs.[F4]
        s2.Cells((etkt2 - 21) * 5 + 3, "B") = irs.[F6]
        s2.Cells((etkt2 - 21) * 5 + 4, "B") = irs.Cells(etkt2, "E")
        s2.Cells((etkt2 - 21) * 5 + 5, "B") = irs.Cells(etkt2, "F")
        s2.Cells((etkt2 - 21) * 5 + 6, "B") = irs.Cells(etkt2, "A")
        s2.Cells((etkt2 - 21) * 5 + 7, "B") = irs.Cells(etkt2, "B")
        s2.Cells((etkt2 - 21) * 5 + 8, "B") = irs.Cells(etkt2, "C")
        a = a + 1
    Else
        s2.Cells((etkt2 - 21) * 5 + 2, "B").ClearContents
        s2.Cells((etkt2 - 21) * 5 + 3, "B").ClearContents
        s2.Cells((etkt2 - 21) * 5 + 4, "B").ClearContents
        s2.Cells((etkt2 - 21) * 5 + 5, "B").ClearContents
        s2.Cells((etkt2 - 21) * 5 + 6, "B").ClearContents
        s2.Cells((etkt2 - 21) * 5 + 7, "B").ClearContents
        s2.Cells((etkt2 - 21) * 5 + 8, "B").ClearContents
    End If
    
    If irs.Cells(etkt2 + 1, "A") <> "" Then
        s2.Cells((etkt2 - 21) * 5 + 2, "E") = irs.[F4]
        s2.Cells((etkt2 - 21) * 5 + 3, "E") = irs.[F6]
        s2.Cells((etkt2 - 21) * 5 + 4, "E") = irs.Cells(etkt2 + 1, "E")
        s2.Cells((etkt2 - 21) * 5 + 5, "E") = irs.Cells(etkt2 + 1, "F")
        s2.Cells((etkt2 - 21) * 5 + 6, "E") = irs.Cells(etkt2 + 1, "A")
        s2.Cells((etkt2 - 21) * 5 + 7, "E") = irs.Cells(etkt2 + 1, "B")
        s2.Cells((etkt2 - 21) * 5 + 8, "E") = irs.Cells(etkt2 + 1, "C")
        a = a + 1
    Else
        s2.Cells((etkt2 - 21) * 5 + 2, "E").ClearContents
        s2.Cells((etkt2 - 21) * 5 + 3, "E").ClearContents
        s2.Cells((etkt2 - 21) * 5 + 4, "E").ClearContents
        s2.Cells((etkt2 - 21) * 5 + 5, "E").ClearContents
        s2.Cells((etkt2 - 21) * 5 + 6, "E").ClearContents
        s2.Cells((etkt2 - 21) * 5 + 7, "E").ClearContents
        s2.Cells((etkt2 - 21) * 5 + 8, "E").ClearContents
    End If
Next

For etkt3 = 31 To 34 Step 2
    If irs.Cells(etkt3, "A") <> "" Then
        s3.Cells((etkt3 - 31) * 5 + 2, "B") = irs.[F4]
        s3.Cells((etkt3 - 31) * 5 + 3, "B") = irs.[F6]
        s3.Cells((etkt3 - 31) * 5 + 4, "B") = irs.Cells(etkt3, "E")
        s3.Cells((etkt3 - 31) * 5 + 5, "B") = irs.Cells(etkt3, "F")
        s3.Cells((etkt3 - 31) * 5 + 6, "B") = irs.Cells(etkt3, "A")
        s3.Cells((etkt3 - 31) * 5 + 7, "B") = irs.Cells(etkt3, "B")
        s3.Cells((etkt3 - 31) * 5 + 8, "B") = irs.Cells(etkt3, "C")
        a = a + 1
    Else
        s3.Cells((etkt3 - 31) * 5 + 2, "B").ClearContents
        s3.Cells((etkt3 - 31) * 5 + 3, "B").ClearContents
        s3.Cells((etkt3 - 31) * 5 + 4, "B").ClearContents
        s3.Cells((etkt3 - 31) * 5 + 5, "B").ClearContents
        s3.Cells((etkt3 - 31) * 5 + 6, "B").ClearContents
        s3.Cells((etkt3 - 31) * 5 + 7, "B").ClearContents
        s3.Cells((etkt3 - 31) * 5 + 8, "B").ClearContents
    End If
    
    If irs.Cells(etkt3 + 1, "A") <> "" Then
        s3.Cells((etkt3 - 31) * 5 + 2, "E") = irs.[F4]
        s3.Cells((etkt3 - 31) * 5 + 3, "E") = irs.[F6]
        s3.Cells((etkt3 - 31) * 5 + 4, "E") = irs.Cells(etkt3 + 1, "E")
        s3.Cells((etkt3 - 31) * 5 + 5, "E") = irs.Cells(etkt3 + 1, "F")
        s3.Cells((etkt3 - 31) * 5 + 6, "E") = irs.Cells(etkt3 + 1, "A")
        s3.Cells((etkt3 - 31) * 5 + 7, "E") = irs.Cells(etkt3 + 1, "B")
        s3.Cells((etkt3 - 31) * 5 + 8, "E") = irs.Cells(etkt3 + 1, "C")
        a = a + 1
    Else
        s3.Cells((etkt3 - 31) * 5 + 2, "E").ClearContents
        s3.Cells((etkt3 - 31) * 5 + 3, "E").ClearContents
        s3.Cells((etkt3 - 31) * 5 + 4, "E").ClearContents
        s3.Cells((etkt3 - 31) * 5 + 5, "E").ClearContents
        s3.Cells((etkt3 - 31) * 5 + 6, "E").ClearContents
        s3.Cells((etkt3 - 31) * 5 + 7, "E").ClearContents
        s3.Cells((etkt3 - 31) * 5 + 8, "E").ClearContents
    End If
Next
Application.ScreenUpdating = True
MsgBox "İşlem tamamlandı. " & Chr(10) & Chr(10) & a & " adet etiket sayfalara aktarıldı."
End Sub

 

[relaxim]

Yusuf Bey harika olmuş ellerinize sağlık. Gerçek programda bazı veriler veri doğrulama ile geliyor, umarım sıkıntı olmaz. Allah razı olsun...Saygılar...

 

[relaxim]

Yusuf Bey hiç bir sıkıntı çıkmadı. Tekrar teşekkürler...