Çözüldü Ürün bilgisi çekme, yeni liste oluşumu ve satır çoğaltma

[netzone]

Merhaba,

Forumda elbette birçok kez paylaştığınız ve bizleri bilgilendirdiğiniz uyarlamaları bir araya getirip bu çalışmayı kendi çabalarımla yapmayı deneyebilirim. Fakat gözlerimle ilgili yaşadığım geçici bir rahatsızlığım bulunmakta. Bu nedenle bir arkadaşımın yardım talep etmesi üzerine bende sizlerden yardım talebinde bulunmak istedim.

Dosya içinde dilim döndüğü kadar örnekleme yaparak anlatmaya çalıştım.

Özetle yapmak istediğimiz işlem: guncelle isimli sayfada okutulan barkod veri sayfasında bulunan bilgileri ekrana getirecek, kullanıcı tarafından bilgilerin doğruluğu teyit edilip eklemeler-düzeltmeler yapılıp liste sayfasına aktarılacak. Barkod / Etiket basımı için ise liste sayfasında bulunan ETİKET SAYISI sıfırdan büyük olanları görünen miktar kadar etiket_listesi sayfasına aktaracak.

*Veriler temsili olarak girilmiştir.

Yardımlarınız için şimdiden teşekkür eder iyi çalışmalar dilerim.

 

[YUSUF44]

Merhaba. Öncelikle geçmiş olsun, tez zamanda şifa bulursunuz inşallah.

guncelle sayfasında bulunan bilgiler liste sayfasıdna varsa güncellemek, yoksa eklemek için aşağıdaki makroyu kullanabilirsiniz:

Sub listeye_aktar()
Set s1 = Sheets("veri")
Set s2 = Sheets("guncelle")
Set s3 = Sheets("liste")
son1 = s1.Cells(Rows.Count, "A").End(3).Row
son3 = s3.Cells(Rows.Count, "A").End(3).Row
If WorksheetFunction.CountIf(s3.Range("A1:A" & son3), s2.[A3]) > 0 Then
    uyarı = MsgBox(s2.[A3] & " barkod nolu ürün Liste sayfasında bulunmaktadır!" & Chr(10) & _
            "Mevcut bilgiler güncellensin mi?", vbYesNo)
    If uyarı = vbYes Then
        sıra = WorksheetFunction.Match(s2.[A3], s3.Range("A1:A" & son3), 0)
        s3.Cells(sıra, "B") = s2.[A5]
        s3.Cells(sıra, "C") = s2.[B5]
        s3.Cells(sıra, "D") = s2.[A7]
        s3.Cells(sıra, "E") = s2.[B7]
        s3.Cells(sıra, "F") = s2.[C7]
        s3.Cells(sıra, "G") = s2.[B3]
        s3.Cells(sıra, "H") = s2.[C4]
        s3.Cells(sıra, "I") = s2.[C3]
        MsgBox s2.[A3] & " barkod nolu ürün bilgileri güncellendi"
    Else
        Exit Sub
    End If
Else
    uyarı1 = MsgBox(s2.[A3] & " barkod nolu ürün Liste sayfasında bulunmamaktadır!" & Chr(10) & _
            "Mevcut bilgilerle yeni kayıt olarak eklensin mi?", vbYesNo)
    If uyarı1 = vbYes Then
        s3.Cells(son3 + 1, "A") = s2.[A3]
        s3.Cells(son3 + 1, "B") = s2.[A5]
        s3.Cells(son3 + 1, "C") = s2.[B5]
        s3.Cells(son3 + 1, "D") = s2.[A7]
        s3.Cells(son3 + 1, "E") = s2.[B7]
        s3.Cells(son3 + 1, "F") = s2.[C7]
        s3.Cells(son3 + 1, "G") = s2.[B5]
        s3.Cells(son3 + 1, "H") = s2.[C4]
        s3.Cells(son3 + 1, "I") = s2.[C3]
        MsgBox s2.[A3] & " barkod nolu Liste sayfasına eklendi"
    Else
        Exit Sub
    End If
End If
End Sub

 

[YUSUF44]

Liste sayfasındaki verileri etiket listesi sayfasına aktarmak için ise aşağıdaki makroyu kullanabilirsiniz:

Sub etikete_aktar()
Set s1 = Sheets("etiket_listesi")
Set s2 = Sheets("liste")
son1 = WorksheetFunction.Max(2, s1.Cells(Rows.Count, "A").End(3).Row)
son2 = WorksheetFunction.Max(2, s2.Cells(Rows.Count, "A").End(3).Row)

If WorksheetFunction.CountIf(s2.Range("I1:I" & son1), ">0") > 0 Then
    uyarı = MsgBox("Etiket listesindeki eski veriler silinip yeni liste oluşturulsun mu?", vbYesNo)
    s1.Range("A2:D" & son1).ClearContents
    If uyarı = vbYes Then
        For i = 2 To son2
            If s2.Cells(i, "I") > 0 Then
                yeni = WorksheetFunction.Max(2, s1.Cells(Rows.Count, "A").End(3).Row + 1)
                s1.Range(Cells(yeni, "A"), Cells(yeni + s2.Cells(i, "I") - 1, "A")) = s2.Cells(i, "A")
                s1.Range(Cells(yeni, "B"), Cells(yeni + s2.Cells(i, "I") - 1, "B")) = s2.Cells(i, "B")
                s1.Range(Cells(yeni, "C"), Cells(yeni + s2.Cells(i, "I") - 1, "C")) = s2.Cells(i, "E")
                s1.Range(Cells(yeni, "D"), Cells(yeni + s2.Cells(i, "I") - 1, "D")) = s2.Cells(i, "H")
            End If
        Next
        MsgBox "Etiket Lsitesi hazırlandı"
    Else
        Exit Sub
    End If
Else
    MsgBox "Liste sayfasında basılacak etiket bulunmamaktadır!", vbCritical
    Exit Sub
End If
End Sub

 

[netzone]

Merhaba Yusuf Bey,
Öncelikle temenni ve yardımınız için teşekkür ederim.
Verdiğiniz kodları kullandığımda 1. Mesajınız işlevini sorunsuz gerçekleştirmiştir. 2. Mesajınızda yer alan kodlar ise " run time error '1004' " hatası vermektedir. İlgili sütunda yer alan değerler kontrol edilmiş ve sayı biçimde görüntülendiği görülmüştür. Hatanın çözümüne ilişkin ve guncelle sayfasına eklenecek olan yeni bir buton ile mevcut formüllerin makro ile arama yapıp bilgileri getirmesi hususunda yardımınızı talep etmekteyim.

İyi çalışmalar dilerim.

 

[YUSUF44]

etiket listesi hazırlama için aşağıdaki makroyu kullanın, bir öncekinde hatalar yapmışım:

Sub etikete_aktar()
Set s1 = Sheets("etiket_listesi")
Set s2 = Sheets("liste")
son1 = WorksheetFunction.Max(2, s1.Cells(Rows.Count, "A").End(3).Row)
son2 = WorksheetFunction.Max(2, s2.Cells(Rows.Count, "A").End(3).Row)

If WorksheetFunction.CountIf(s2.Range("I1:I" & son2), ">0") > 0 Then
    uyarı = MsgBox("Etiket listesindeki eski veriler silinip yeni liste oluşturulsun mu?", vbYesNo)
    s1.Range("A2:D" & son1).ClearContents
    If uyarı = vbYes Then
        For i = 2 To son2
            If s2.Cells(i, "I") > 0 Then
                yeni = WorksheetFunction.Max(2, s1.Cells(Rows.Count, "A").End(3).Row + 1)
                s1.Range(s1.Cells(yeni, "A"), s1.Cells(yeni + s2.Cells(i, "I") - 1, "A")) = s2.Cells(i, "A")
                s1.Range(s1.Cells(yeni, "B"), s1.Cells(yeni + s2.Cells(i, "I") - 1, "B")) = s2.Cells(i, "B")
                s1.Range(s1.Cells(yeni, "C"), s1.Cells(yeni + s2.Cells(i, "I") - 1, "C")) = s2.Cells(i, "E")
                s1.Range(s1.Cells(yeni, "D"), s1.Cells(yeni + s2.Cells(i, "I") - 1, "D")) = s2.Cells(i, "H")
            End If
        Next
        MsgBox "Etiket Lsitesi hazırlandı"
    Else
        Exit Sub
    End If
Else
    MsgBox "Liste sayfasında basılacak etiket bulunmamaktadır!", vbCritical
    Exit Sub
End If
End Sub

 

[netzone]

Yusuf Bey, gönderdiğiniz kodlar sonucu dosya kullanıma hazır hale geldi. Teşekkür ederim.

İlgili sayfanın formüllerini koda çevirmek için, aşağıdaki kod ile çözüme ulaştırdım.

Private Sub Worksheet_Change(ByVal Target As Range)
    If Intersect(Target, [A3]) Is Nothing Then Exit Sub
        [A5] = [iferror(vlookup(A3,urun_verileri,2,False),"")]
        [B5] = [iferror(vlookup(A3,urun_verileri,3,False),"")]
        [A7] = [iferror(vlookup(A3,urun_verileri,4,False),"")]
        [B7] = [iferror(vlookup(A3,urun_verileri,5,False),"")]
        [C4] = [iferror(vlookup(A3,urun_verileri,7,False),"")]
        [C7] = [iferror(vlookup(A3,urun_verileri,6,False),"")]
End Sub

İyi çalışmalar.

 

[turist]

Merhaba,

.... gözlerimle ilgili yaşadığım geçici bir rahatsızlığım bulunmakta. ...................

Sayın @netzone ,
Geçmiş olsun, acil şifalar dilerim.

 

[assenucler]

Merhaba,

Fakat gözlerimle ilgili yaşadığım geçici bir rahatsızlığım bulunmakta.

Üstadım geçmiş olsun. Bir an önce iyileşmenizi diliyorum.

 

[netzone]

Sayın @netzone ,
Geçmiş olsun, acil şifalar dilerim.

Üstadım geçmiş olsun. Bir an önce iyileşmenizi diliyorum.

Sağolun, Teşekkür ederim.