Dosya İçindeki Veriler İçin ETİKET Oluşturma..!

[syilmaz38]

Arkadaşlar merhaba,

Sıkıntım şöyle, biz hava kanalı imalatı yapıyoruz. Müşterilerin siparişleri daha anlaşılır şekilde gönderebilmesi için ekteki linkte bulunan sipariş dosyamızı oluşturduk. Siparişlerin sevki öncesi etiket yapıştırmamız gerekiyor. Her parça için etiket oluşturmamız gerekiyor. Bu etiketleri de tek tek el ile yapıyorum ve mesaimin %40 ını bu işe harcıyorum. El ile yaptığımız için hata da olabiliyor. Verilerin hepsi değişken olduğu için etiket makinesi de işimizi görmüyor.

Her parça için farklı stünlarda formül oluşturarak çözmek istedim fakat parça miktarları da değişken olduğu için her parçanın miktarınca etiket oluşturmam gerekiyor. Bazı satırlar da miktar 1 olurken bazı satırlarda 200 ü geçebiliyor.

Formül vs az buçuk çakıyoruz ama VBA çok farklı bi olay ve hiç anlamadığım bi konu. Bu durum VBA ile çözülebilir mi?


Örnek dosya
http://dosya.co/6digbautfxhw/ETİKET_DENEME.xlsx.html

 

[ÖmerBey]

Etiket üzerine yazdığınız ürün ölçülerinde bir standart bulamadığım için ölçü kısmını biraz değiştirerek aşağıdaki kodu oluşturdum. Probleminizi tamamen çözmez belki ama işinizi kolaylaştırabilir. Deneyiniz...

Sub KOD()
Dim MT As Worksheet, Syf As Worksheet
Dim Ürünler()
Dim Ad(), SipNo(), Ölçü(), Açıklama()
Set MT = Sheets("METRAJ TOPLAM")
For a = 11 To 24
    If MT.Cells(a, "D") > 0 Then
        x = x + 1
        ReDim Preserve Ürünler(1 To x)
        Ürünler(x) = MT.Cells(a, "C")
    End If
Next
i = 0
For Each ürün In Ürünler
    Set Syf = Sheets(ürün)
    mik = WorksheetFunction.Match("MİKTAR", Syf.Range("10:10"), 0)
    For a = 11 To Syf.Range("B65500").End(3).Row
        ReDim olc(2 To mik - 1)
        For b = 2 To mik - 1
            olc(b) = Split(Syf.Cells(10, b), "(")(0) & "= " & Syf.Cells(a, b)
        Next

        For j = 1 To Syf.Cells(a, mik)
            ReDim Preserve Ad(i)
            ReDim Preserve SipNo(i)
            ReDim Preserve Ölçü(i)
            ReDim Preserve Açıklama(i)
            Ad(i) = ürün
            SipNo(i) = Syf.Range("C6")
            Ölçü(i) = Join(olc, vbLf)
            Açıklama(i) = Syf.Cells(a, WorksheetFunction.Match("AÇIKLAMA", Syf.Range("10:10"), 0))
            i = i + 1
        Next
    Next
Next
Set Syf = Sheets("ETİKET ")
Syf.Cells.ClearContents
For a = LBound(Ad) To UBound(Ad) Step 2
    Syf.Cells(a * 5 + 1, "A") = SipNo(a)
    Syf.Cells(a * 5 + 1, "C") = Ad(a)
    Syf.Cells(a * 5 + 6, "A") = Açıklama(a)
    Syf.Cells(a * 5 + 4, "C") = Ölçü(a)
    
    If a = UBound(Ad) Then Exit For

    Syf.Cells(a * 5 + 1, "F") = SipNo(a + 1)
    Syf.Cells(a * 5 + 1, "H") = Ad(a + 1)
    Syf.Cells(a * 5 + 6, "F") = Açıklama(a + 1)
    Syf.Cells(a * 5 + 4, "H") = Ölçü(a + 1)
Next
End Sub

 

[syilmaz38]

Etiket üzerine yazdığınız ürün ölçülerinde bir standart bulamadığım için ölçü kısmını biraz değiştirerek aşağıdaki kodu oluşturdum. Probleminizi tamamen çözmez belki ama işinizi kolaylaştırabilir. Deneyiniz...

Üstad ilgin için teşekkür ederim. Zahmet verdik uğraştırdık seni. 2 gündür uğraşıyorum ama yazılım dilinden anlamadığım için işin içinden çıkamadım.

Şöyle bi çözüm yolu buldum. Benim sıkıntım aynı parçayı miktarınca aşağıya doğru saydırmak ve altındaki parçayı da aynı şekilde aşağıya doğru devam ettirmek.

Aşağıdaki linkteki örnekte olduğu gibi etiket vurulması gereken ihtiyacım olan parçaları ayrı ayrı sağ tarafa doğru uzattım. Bana sadece dosya içinden parça miktarlarınca ölçüleri sıralayabilirsen etiket formatını farklı bi sekmede istediğim gibi şekillendirebilirim.

Dilim döndüğünce anlatmaya çalıştım. Yardımcı olabilirsen çok sevinirim...

http://dosya.co/jz0cdnl6sqnx/ETİKET.xlsx.html

http://dosya.co/cjir0ch89thy/1A.jpg.html

 

[ÖmerBey]

Şu kodları deneyiniz...

Not: Kodların doğru çalışabilmesi için sayfa isimlerinin ve Etiket Yeni sayfası 2. satırdaki ürün isimlerinin Metraj Toplam sayfasındakiler ile aynı olması gerekmektedir. Örnek:YAKA (SAPLAMA)

Sub KOD1()
Dim MT As Worksheet, Syf As Worksheet, EY As Worksheet
Dim Ürünler()
Set MT = Sheets("METRAJ TOPLAM")
Set EY = Sheets("ETİKET YENİ")
EY.Range("C4:G2503,I4:N2503,P4:V2503,X4:AF2503,AH4:AO2503,AQ4:BA2503,BC4:BM2503,BO4:BU2503").ClearContents
For a = 11 To 24
    If MT.Cells(a, "D") > 0 Then
        x = x + 1
        ReDim Preserve Ürünler(1 To x)
        Ürünler(x) = MT.Cells(a, "C")
    End If
Next

For Each ürün In Ürünler
    Set Syf = Sheets(ürün)
    mik = WorksheetFunction.Match("MİKTAR", Syf.Range("10:10"), 0)
    süt = WorksheetFunction.Match(ürün, EY.Range("2:2"), 0)
    For a = 11 To Syf.Range("B65500").End(3).Row

        For j = 1 To Syf.Cells(a, mik)
            sat = EY.Cells(Rows.Count, süt + 1).End(3).Row + 1
            For i = 2 To mik - 1
                EY.Cells(sat, i + süt - 1) = Syf.Cells(a, i)
            Next
            EY.Cells(sat, i + süt - 1) = 1
            EY.Cells(sat, i + süt) = Syf.Cells(a, WorksheetFunction.Match("AÇIKLAMA", Syf.Range("10:10"), 0))
        Next
    Next
Next
End Sub

 

[syilmaz38]

Şu kodları deneyiniz...

Not: Kodların doğru çalışabilmesi için sayfa isimlerinin ve Etiket Yeni sayfası 2. satırdaki ürün isimlerinin Metraj Toplam sayfasındakiler ile aynı olması gerekmektedir. Örnek:YAKA (SAPLAMA)

Üstad on numara oldu. Beni büyük bi dertten kurtardın. Ellerine sağlık teşekkür ederim....