Soru Listeden ürün bilgisi çekme ve miktar kadar çoğaltma işlemi

[Alperen25]

Merhaba arkadaşlar,

Bir excel dosyam var.
Bu dosya ile belirli bir şablona göre etiket yazdırmak istiyorum.
Şablonum 3X11 formunda hazırlandı. (tanex etiket şablonu 3 sütun 11 satır)
Ürün listem de hazır.
Ama bu ikisi arasındaki bağlantıyı tam olarak kuramadım.

Çalışma şekli şöyle olabilir (veya daha pratik bir yöntem var ise o şekilde de olabilir. hiç mühim değil)

Birinci sayfada listem var.
İkinci sayfada şablonum var.
Şablonum olduğu sayfaya bir buton, bir de ürün seçmek için liste ekledim.
Bunların altına ya da sağına da miktar yazabileceğim hücre var diyelim.
Ben listeden ürünü seçip miktarını yazıp butona basınca o modele ait parça kodları şablonum üzerindeki boş olan hücrelere yerleşsin.
Mesela miktar 1 olarak girilmişse şablonda KTF.01 kodundan 8 adet yazmalı. KTF3015.01 kodunda 2 adet yazmalı. Miktar 2 olarak girilmişse 2 katı kadar yazmalı.
Sayfa1 bitince Sayfa2'ye, 2 bitince 3'e devam edecek şekilde sağdan sola veya yukarıdan aşağıya yerleşebilir hiç mühim değil ama sağdan sola yerleşmesi kağıt israfı olmaması için daha uygun olacaktır.



Örnek excel dosyasının linki : Etiket hazırlık

İlgilenebilirseniz çok memnun olurum.

Çok teşekkür ederim.

 

[Alperen25]

Örnek gösterim; Model 1 seçilip miktar kısmına da 1 yazıldığı zaman bu şekilde bir yerleşim olmalı.

 

[netzone]

Merhaba,
Dün açmış olduğum benzer konuyu inceleyiniz. Yusuf Bey'in #5 nolu mesajındaki kodu kendinize göre uyarlayabilirsiniz. Akabinde oluşan sayfadaki verileri Word de Adres Mektup Birleştirme ile TANEX şablonunuzu seçip kaynak olarak göstermeniz halinde A4 formunda etiketlerinizi kolay bir şekilde hazırlayabilirsiniz.
*Lazer yazıcılarda şablonlar yarım santim kadar aşağı kayabilir kağıdın üst boşluğunu alacağınız test çıktısı sonrasında kayan ölçüde küçültünüz.

İyi çalışmalar.

 

[YUSUF44]

Sayın netzone belirtmiş ancak, sizin isteğiniz bahsedilen konudan biraz daha karışık.

Aşağıdaki makroyu bir modüle kopyalayıp deneyiniz:

Sub etiket()
Set s1 = Sheets("Model")
Set s2 = Sheets("Etiket")

son = s1.Cells(Rows.Count, "A").End(3).Row
If s2.[A2] = "" Then
    MsgBox "Lütfen Model Adı bilgisini giriniz"
    Exit Sub
ElseIf s2.[B2] = "" Then
    MsgBox "Miktar bilgisini giriniz"
    Exit Sub
ElseIf IsNumeric(s2.[B2]) = False Then
    MsgBox "Lütfen Miktar bilgisini tamsayı olarak giriniz"
    Exit Sub
ElseIf s2.[B2] <> Int(s2.[B2]) Then
    MsgBox "Lütfen Miktar bilgisini tamsayı olarak giriniz"
    Exit Sub
ElseIf WorksheetFunction.CountIf(s1.Range("A1:A" & son), s2.[A2]) = 0 Then
    MsgBox "Belirtilen model, model listesinde bulunmamaktadır!", vbCritical
    Exit Sub
End If
For i = 2 To son
    If s1.Cells(i, "A") = s2.[A2] Then
        miktar = s1.Cells(i, "D") * s2.[B2]
    
        If s2.[D1] = "" Then
            s2.[D1] = s1.Cells(i, "C")
            miktar = miktar - 1
            If miktar > 0 Then
                GoTo 10
            Else
                Exit Sub
            End If
        End If
10:
        sütun = WorksheetFunction.Max(4, s2.Cells(1, Columns.Count).End(xlToLeft).Column)
        satır = s2.Cells(Rows.Count, sütun).End(3).Row
        sütun = WorksheetFunction.Max(4, s2.Cells(satır, Columns.Count).End(xlToLeft).Column)
        
        If satır = 11 And sütun Mod 3 = 0 Then
            satır = 1
            sütun = sütun + 1
            s2.Cells(satır, sütun) = s1.Cells(i, "C")
            miktar = miktar - 1
        ElseIf sütun Mod 3 = 0 Then
            If Cells(satır + 1, sütun - 2) <> "" And Cells(satır + 1, sütun - 1) <> "" Then
                satır = satır + 1
            ElseIf Cells(satır + 1, sütun - 2) <> "" Then
                satır = satır + 1
                sütun = sütun - 1
            Else
                satır = satır + 1
                sütun = sütun - 2
            End If
            s2.Cells(satır, sütun) = s1.Cells(i, "C")
            miktar = miktar - 1
        Else
            sütun = sütun + 1
            s2.Cells(satır, sütun) = s1.Cells(i, "C")
            miktar = miktar - 1
        End If
        If miktar > 0 Then
            GoTo 10
        Else
            GoTo 20
        End If
    End If
Next
20:
MsgBox "İşlem Tamamlandı :)"

End Sub

 

[halit3]

Alternatif kod:
Ekli resimlerdeki gibi
Etiket ve Model sayfalarınıza ait
verileriniz satır ve sutunlarda olmalı satır ve sutünlara dikkat edilmeli

Sub etiket_yaz()

If Sheets("Model").Cells(2, 10).Value <= 0 Then MsgBox "miktar sıfırdan büyük olmalı": Exit Sub

Worksheets("Etiket").Rows("1:11").ClearContents

sat = 1
sut = 1
ekle = 0



For r = 2 To Worksheets("Model").Cells(Rows.Count, "a").End(3).Row
bulunan1 = Sheets("Model").Cells(r, 1).Value

For n = 1 To Sheets("Model").Cells(2, 10).Value
aranan1 = Sheets("Model").Cells(2, 9).Value

If aranan1 = bulunan1 Then
If Val(Sheets("Model").Cells(r, 4).Value) > 0 Then
For j = 1 To Sheets("Model").Cells(r, 4).Value
Sheets("Etiket").Cells(sat, sut + ekle).Value = Sheets("Model").Cells(r, 3).Value
'MsgBox Sheets("Model").Cells(r, 3).Value
sut = sut + 1
If sut = 4 Then
sat = sat + 1
sut = 1
End If

If sat = 12 Then
sat = 1
ekle = ekle + 3

End If
Next j
End If
End If
Next n
Next r

MsgBox " Düzenleme Tamanlanmıştır..."

End Sub

 

[Alperen25]

Evet bu şekilde çalışıyor. Çok çok teşekkür ederim arkadaşlar.

 

[halit3]

As önce dosyaları yeniden güncelledim.

 

[Alperen25]

Halit Bey "miktar sıfırdan büyük olmalı" hatası veriyor. Yusuf Bey'in göndermiş olduğu kod şuan için çalışıyor. Çok çok teşekkür ederim.

 

[muygun]

Merhaba;
Bir alternatifte benden
İnceleyin.
İyi çalışmalar.

 

[halit3]

Üstad bu kodda sayfa sınırlaması yapmasak sayfa ismi kısıtlaması da yapmasak kaç tane sayfa varsa hepsinden silse.
Ayrıca World dosyaları için bir kod varmıdır?

Halit Bey "miktar sıfırdan büyük olmalı" hatası veriyor. Yusuf Bey'in göndermiş olduğu kod şuan için çalışıyor. Çok çok teşekkür ederim.

Göndermiş olduğum dosyada Model sayfasında J2 hücresinde miktar sayısı olmalı yoksa aktarım yapmaz.

 

[Alperen25]

Çok teşekkür ederim arkadaşlar.

Yusuf Bey, sizin kodunuzu şuan deniyorum ama hata alıyorum.



Bu şekilde yazıyor. Diğer parçaları yazmıyor. Kopyaladım ama atladığım bir yer mi var?

 

[YUSUF44]

Nasıl bir hata alıyorsunuz? Hatalı haliyle dosyayı yükler misiniz?

 

[Alperen25]

Buyurun Yusuf Bey, hatalı halini ekledim.

 

[YUSUF44]

Dosyanızda ne gibi bir hata var? Bende hata vermedi. A2'de üstüste Model 1 ve sorna da üstüste Model 2 seçtiğimde etiketleri düzgünce hazırladı.

 

[halit3]

5 nolu mesajdaki dosya ile ilgili bir şey yazmadınız

 

[halit3]

Bu uygulamada 1 nolu mesajınızdaki dosya ya ait uygulama

 

[Alperen25]

5 nolu mesajdaki dosya ile ilgili bir şey yazmadınız

Merhaba Halit Bey, dediğiniz gibi J2 hücresine miktar yazıyorum ama etiket yazmıyor ve a ve b sütunlarını siliyor.



Butona basınca gelen ekran;

 

[Alperen25]

Bu uygulamada 1 nolu mesajınızdaki dosya ya ait uygulama

Halit Bey, çok teşekkür ederim. Bu dosyalar da çalışıyor ama her defasında sıfırdan yazıyor. Yani üzerine ekleme yapmıyor.
Sayfayı temizliyor ve kodları en baştan yazmaya başlıyor. Temizleme işlemini yapmasa, ya da temizleme işlemini ayrı bir butona ekleyebilir miyiz?
Çünkü bu şekilde olursa çok fazla kağıt israf olur. Mesela Model 1'den 2 adet yazdırdıktan sonra üstüne Model 2'den ekleme yapabilmem lazım.

 

[Alperen25]

Dosyanızda ne gibi bir hata var? Bende hata vermedi. A2'de üstüste Model 1 ve sorna da üstüste Model 2 seçtiğimde etiketleri düzgünce hazırladı.

Yusuf Bey, ilk çalıştırdığımda bende de düzgün çalışıyordu ama şimdi sadece birinci sıradaki hücreyi yazdırıyor. Diğerlerini yazdırmıyor.

Ekrana bu şekilde geliyor:

 

[YUSUF44]

Anladım.

20: satırını Next satırından önceye alıp dener misiniz?