• DİKKAT

    DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
    Altın Üyelik Hakkında Bilgi

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

  • Konbuyu başlatan Konbuyu başlatan relaxim
  • Başlangıç tarihi Başlangıç tarihi
relaxim

relaxim

Altın Üye
Katılım
30 Ağustos 2009
Mesajlar
589
Excel Vers. ve Dili
LTSC Pro Plus 2024 Türkçe
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.
 

Ekli dosyalar

Güncel...
 
Günceldir...Saygılar...
 
Aşağıdaki makroyu deneyiniz:

PHP: 
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
 
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...
 
Yusuf Bey hiç bir sıkıntı çıkmadı. Tekrar teşekkürler...
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst