En Fazla Ürün Türü Seçtirme

[DMR 7]

Merhabalar,

Aşağıdaki liste için;

En fazla ürün türünü, en pahalı şekilde ve her bayiiden 5 adet ürün seçerek nasıl yapabilirim.

* Tüm liste içerisindeki sıklık miktarı ürün bazında, göz önünde bulundurulmalı.
* Bir Bayii'den 5 adet ürün seçileceği için diğer bayiilerde olmayan ürün varsa kota öncelikle bu ürünlerden doldurulmalı.
* Maximum sayıda türe ulaştıktan sonra seçilecek ürünler daha önce seçilenler ile aynı olacaktır. Bu seçimde pahalılığa göre seçim yapılmalı.

A1 B1 C1
Bayii No Tür Fiyat
Bayii 1 Kalem1 5455
Bayii 1 Defter1 5345
Bayii 1 Silgi1 5235
Bayii 1 Dosya1 5125
Bayii 1 Çanta1 4550
Bayii 1 Kalem2 4440
Bayii 1 Defter2 4330
Bayii 1 Silgi2 4220
Bayii 1 Dosya2 4110
Bayii 1 Çanta2 3440
Bayii 1 Kalem3 3330
Bayii 1 Defter3 3220
Bayii 1 Silgi3 3110
Bayii 1 Dosya3 5455
Bayii 1 Çanta3 5345
Bayii 1 Kalem4 5235
Bayii 1 Defter4 5125
Bayii 1 Silgi4 4550
Bayii 1 Dosya4 4440
Bayii 1 Çanta4 4330
Bayii 1 Kalem5 4220
Bayii 1 Defter5 4110
Bayii 1 Silgi5 3440
Bayii 1 Dosya5 3330
Bayii 1 Çanta5 3220
Bayii 2 Dosya1 4110
Bayii 2 Çanta1 3440
Bayii 2 Kalem2 3330
Bayii 2 Defter2 3220
Bayii 2 Silgi2 3110
Bayii 2 Dosya2 5455
Bayii 2 Çanta2 5345
Bayii 2 Kalem3 5235
Bayii 2 Defter3 4220
Bayii 3 Dosya1 3330
Bayii 3 Çanta1 5125
Bayii 3 Kalem2 4550
Bayii 3 Defter2 4440
Bayii 3 Silgi2 4330
Bayii 3 Dosya2 4220
Bayii 3 Çanta2 4110
Bayii 3 Kalem3 3440
Bayii 3 Defter3 3330
Bayii 3 Silgi3 3220
Bayii 3 Dosya3 3110
Bayii 3 Çanta3 5455
Bayii 3 Kalem4 4330
Bayii 3 Defter4 4220
Bayii 3 Silgi4 4110
Bayii 3 Dosya4 3440
Bayii 3 Çanta4 3330
Bayii 4 Kalem3 4440
Bayii 4 Defter3 4330
Bayii 4 Silgi3 4220
Bayii 4 Dosya3 4110
Bayii 4 Çanta3 3440
Bayii 4 Kalem4 3330
Bayii 4 Defter4 3220
Bayii 4 Silgi4 3110
Bayii 4 Dosya4 5455
Bayii 4 Çanta4 5235
Bayii 4 Silgi2 5125
Bayii 4 Dosya2 4550
Bayii 5 Dosya1 3440
Bayii 5 Çanta1 3330
Bayii 5 Kalem2 3220
Bayii 5 Defter2 3110
Bayii 5 Silgi2 5455
Bayii 5 Dosya2 5345
Bayii 5 Çanta2 5235
Bayii 6 Kalem2 4440
Bayii 6 Defter2 4330
Bayii 6 Silgi2 4220
Bayii 6 Dosya2 4110
Bayii 6 Çanta2 3440
Bayii 6 Kalem3 3330
Bayii 6 Defter3 3220
Bayii 6 Silgi3 3110
Bayii 6 Dosya3 5455
Bayii 6 Çanta3 5345
Bayii 7 Kalem1 4550
Bayii 7 Defter1 4440
Bayii 7 Silgi1 4330
Bayii 7 Dosya1 4220
Bayii 7 Çanta1 4110
Bayii 7 Kalem2 3440
Bayii 7 Defter2 3330
Bayii 7 Silgi2 5455
Bayii 7 Dosya2 5345
Bayii 7 Çanta2 5235
Bayii 7 Kalem3 5125
Bayii 7 Defter3 4550
Bayii 7 Silgi3 4440
Bayii 7 Dosya3 4330
Bayii 7 Çanta3 4110
Bayii 8 Kalem3 3440
Bayii 8 Defter3 3330
Bayii 8 Silgi3 3220
Bayii 8 Dosya3 3110
Bayii 8 Çanta3 5455
Bayii 8 Kalem4 5345
Bayii 8 Defter4 5235
Bayii 8 Silgi4 4330
Bayii 8 Dosya4 4220
Bayii 8 Çanta4 4110
Bayii 8 Kalem1 3440
Bayii 8 Defter1 3330
Bayii 9 Dosya1 3440
Bayii 9 Çanta1 3330
Bayii 9 Kalem2 3220
Bayii 9 Defter2 3110
Bayii 9 Silgi2 5455
Bayii 9 Dosya2 5345
Bayii 9 Çanta2 5235
Bayii 9 Kalem3 5125
Bayii 9 Defter3 4550
Bayii 9 Silgi3 4440
Bayii 9 Kalem6 4220
Bayii 9 Defter6 4110
Bayii 9 Silgi6 3440
Bayii 9 Dosya6 3330
Bayii 9 Çanta6 3220
Bayii 9 Dosya7 3440
Bayii 9 Çanta7 4440
Bayii 10 Kalem1 3220
Bayii 10 Defter1 5125
Bayii 10 Silgi1 4550
Bayii 10 Dosya1 4440
Bayii 10 Çanta1 4330

 

[antonio]

Dosyanız ektedir.

 

[DMR 7]

Dosyanız ektedir.

Teşekkür ederim size, fakat dosyayı indiremiyorum. Üyeliğim uygun değil sanırım sitede yeniyim. Farklı bir yol ile iletebilir misiniz veya kodu paylaşabilir misiniz?

Totalde seçilecek 50 ürün içersinde, tüm liste içinde bulunan 32 çeşitten 30'unun olmasını istiyorum.(Bayii 9'da 7 unique ürün var ve en fazla 5 seçilebildiğinden 2 tanesi boşta kalıyor.) En fazla ürün türünden kastım bayi bazında değilde, tüm bayiler için seçilecek 50 ürün içindi. Sizin sonucunuzu merak ediyorum.

 

[antonio]

Kendi dosyanıza aşağıdaki kodları uyarlayabilirsiniz.
Belirttiğiniz gibi A sütunda Bayi isimleri, B sütununda Ürünler, ve C sütununda fiyatlar bulunmalı. Sayfa1 sekmesine sağ tıklayıp "Kod Görüntüle" yi tıklayın. Açılan kod ekranına aşağıdaki kodları aynen kopyalayıp yapıştırın.

Sub urunleri_bul()
Dim sh As Worksheet, ss As Long, a, b, i As Long, n As Long

Set sh = Sayfa1
ss = sh.Range("A" & Rows.Count).End(3).Row
a = sh.Range("A2:C" & ss).Value
ReDim b(1 To 3, 1 To 1)
n = 1
s = n

Set z = CreateObject("Scripting.Dictionary")
    z.comparemode = vbTextCompare
    For i = 1 To UBound(a)
        aranan = a(i, 2)
        If Not z.exists(aranan) Then
            z.Add aranan, n
            z(aranan) = n
            s = n
            ReDim Preserve b(1 To 3, 1 To n)
            b(1, n) = a(i, 1)
            b(2, n) = aranan
            b(3, n) = a(i, 3)
            n = n + 1
        Else
            s = z(aranan)
            b(1, s) = b(1, s) & " / " & a(i, 1)
            b(3, s) = b(3, s) & " == " & a(i, 3)
        End If
    Next i
sh.Range("F2:H" & Rows.Count).ClearContents
sh.Range("F2").Resize(n - 1, 3).Value = Application.Transpose(b)
i = 2
Erase b
ss = sh.Range("F" & Rows.Count).End(3).Row
sh.Range("J2:L" & Rows.Count).ClearContents
For i = 2 To ss
    bayiler = sh.Range("F" & i).Value
        bayi = Split(Trim(bayiler), "/")
    urun = sh.Range("G" & i).Value
    fiyatlar = sh.Range("H" & i).Value
        fiyat = Split(Trim(fiyatlar), "==")
    If UBound(fiyat) > 0 Then
        uygun_fiyat = Evaluate("[COLOR="Red"][B]Max[/B][/COLOR](" & Join(fiyat, ",") & ")")
        For d = 0 To UBound(fiyat)
            If fiyat(d) * 1 = uygun_fiyat Then
                sh.Range("J" & i).Value = bayi(d)
                sh.Range("K" & i).Value = urun
                sh.Range("L" & i).Value = fiyat(d)
                Exit For
            End If
        Next d
    Else
                sh.Range("J" & i).Value = bayi(0)
                sh.Range("K" & i).Value = urun
                sh.Range("L" & i).Value = fiyat(0)
    End If
Next i
sh.Range("J2:K" & ss).Sort key1:=[J2], order1:=xlAscending, Header:=xlGuess
MsgBox "İşlem tamamlandı..", vbInformation, "antonio"
End Sub

NOT: En pahalı şekilde yazmışsınız, bunu kaçırmışım. Yani tam tersi, en hesaplı fiyatları listelemişim. Yinede bir inceleyin, fikirlerinizi paylaşın.

 

[DMR 7]

Kendi dosyanıza aşağıdaki kodları uyarlayabilirsiniz.
Belirttiğiniz gibi A sütunda Bayi isimleri, B sütununda Ürünler, ve C sütununda fiyatlar bulunmalı. Sayfa1 sekmesine sağ tıklayıp "Kod Görüntüle" yi tıklayın. Açılan kod ekranına aşağıdaki kodları aynen kopyalayıp yapıştırın.

Sub urunleri_bul()
Dim sh As Worksheet, ss As Long, a, b, i As Long, n As Long

Set sh = Sayfa1
ss = sh.Range("A" & Rows.Count).End(3).Row
a = sh.Range("A2:C" & ss).Value
ReDim b(1 To 3, 1 To 1)
n = 1
s = n

Set z = CreateObject("Scripting.Dictionary")
    z.comparemode = vbTextCompare
    For i = 1 To UBound(a)
        aranan = a(i, 2)
        If Not z.exists(aranan) Then
            z.Add aranan, n
            z(aranan) = n
            s = n
            ReDim Preserve b(1 To 3, 1 To n)
            b(1, n) = a(i, 1)
            b(2, n) = aranan
            b(3, n) = a(i, 3)
            n = n + 1
        Else
            s = z(aranan)
            b(1, s) = b(1, s) & " / " & a(i, 1)
            b(3, s) = b(3, s) & " == " & a(i, 3)
        End If
    Next i
sh.Range("F2:H" & Rows.Count).ClearContents
sh.Range("F2").Resize(n - 1, 3).Value = Application.Transpose(b)
i = 2
Erase b
ss = sh.Range("F" & Rows.Count).End(3).Row
sh.Range("J2:L" & Rows.Count).ClearContents
For i = 2 To ss
    bayiler = sh.Range("F" & i).Value
        bayi = Split(Trim(bayiler), "/")
    urun = sh.Range("G" & i).Value
    fiyatlar = sh.Range("H" & i).Value
        fiyat = Split(Trim(fiyatlar), "==")
    If UBound(fiyat) > 0 Then
        uygun_fiyat = Evaluate("Min(" & Join(fiyat, ",") & ")")
        For d = 0 To UBound(fiyat)
            If fiyat(d) * 1 = uygun_fiyat Then
                sh.Range("J" & i).Value = bayi(d)
                sh.Range("K" & i).Value = urun
                sh.Range("L" & i).Value = fiyat(d)
                Exit For
            End If
        Next d
    Else
                sh.Range("J" & i).Value = bayi(0)
                sh.Range("K" & i).Value = urun
                sh.Range("L" & i).Value = fiyat(0)
    End If
Next i
sh.Range("J2:K" & ss).Sort key1:=[J2], order1:=xlAscending, Header:=xlGuess
MsgBox "İşlem tamamlandı..", vbInformation, "antonio"
End Sub

NOT: En pahalı şekilde yazmışsınız, bunu kaçırmışım. Yani tam tersi, en hesaplı fiyatları listelemişim. Yinede bir inceleyin, fikirlerinizi paylaşın.

Run time error "424"
Object required

hatası alıyorum ne yapmalıyım hocam.

Yeni bir excel sayfasında düzelttim. Sayfa1'de sıkıntı varmış

 

[DMR 7]

Hocam çalıştırdığımda;

Bayii 10 Kalem1 3220
Bayii 2 Silgi2 3330
Bayii 3 Dosya1 4330
Bayii 3 Dosya3 3330
Bayii 3 Dosya4 3330
Bayii 3 Çanta4 3220
Bayii 4 Çanta3 3110
Bayii 4 Kalem4 3110
Bayii 4 Defter4 4110
Bayii 4 Silgi4 3440
Bayii 5 Çanta1 3330
Bayii 5 Kalem2 3220
Bayii 5 Defter2 3110
Bayii 7 Silgi1 3110
Bayii 8 Defter1 3440
Bayii 1 Kalem5 3330
Bayii 1 Defter5 3220
Bayii 1 Silgi5 3110
Bayii 1 Dosya5 3440
Bayii 1 Çanta5 3330
Bayii 1 Dosya2 4220
Bayii 1 Çanta2 4110
Bayii 1 Kalem3 3440
Bayii 1 Defter3 3330
Bayii 1 Silgi3 3220
Bayii 9 Kalem6 4220
Bayii 9 Defter6 4110
Bayii 9 Silgi6 3440
Bayii 9 Dosya6 3330
Bayii 9 Çanta6 3220
Bayii 9 Dosya7 3440
Bayii 9 Çanta7 4440


en sağ 3 sütunda şöyle bir liste belirdi. Ben bayi başı 5 ürün yerleştirmek istiyorum.

yani herhangi bir bayii'den 5 ürün aldıktan sonra oradan alım kapanmalı.

Başka bir bayii için ise unique'ler yerleştirildikten sonra, seçimi 5'e tamamlamak için aynı ürünlerin pahalılarından seçilmesini istiyorum.

Yani totalde 50 seçim olacak. ve maximum sayıda ürün çeşidi yerleştilecek. kalan ürünler mecburen aynı olacağından onlar pahalı olan ürünlerden seçilecek yine

 

[antonio]

....
yani herhangi bir bayii'den 5 ürün aldıktan sonra oradan alım kapanmalı.
Başka bir bayii için ise unique'ler yerleştirildikten sonra, seçimi 5'e tamamlamak için aynı ürünlerin pahalılarından seçilmesini istiyorum.

Tespit ettiğiniz gibi, en sağ tarafta benzersiz (unique) ürün bazında en düşük fiyat, ve bu fiyata satan bayi bilgileri bulunuyor. Ortadaki 3 sütunda da benzersiz (unique) olarak sıralı ürünleri bulunduran tüm bayilerin yan yana isimleri ve bunların (aynı sıra ile) o ürünü satış fiyatları bulunuyor.
Siz en ucuz fiyat yerine en pahalı fiyat istediğinize göre, kodlardaki "Min" fonksiyonu, Max olarak değiştirmek gerekiyor. Kırmızı renk ile düzeltmeyi yapacağım. Diğer ayrıntılar (her bayiden 5 ürün alımı) için fırsat bulunca bakacağım. Bu arada müsait olan bir arkadaşımız kodları revize eder, size zaman kazandırırsa memnuniyet duyarım.

 

[DMR 7]

Tespit ettiğiniz gibi, en sağ tarafta benzersiz (unique) ürün bazında en düşük fiyat, ve bu fiyata satan bayi bilgileri bulunuyor. Ortadaki 3 sütunda da benzersiz (unique) olarak sıralı ürünleri bulunduran tüm bayilerin yan yana isimleri ve bunların (aynı sıra ile) o ürünü satış fiyatları bulunuyor.
Siz en ucuz fiyat yerine en pahalı fiyat istediğinize göre, kodlardaki "Min" fonksiyonu, Max olarak değiştirmek gerekiyor. Kırmızı renk ile düzeltmeyi yapacağım. Diğer ayrıntılar (her bayiden 5 ürün alımı) için fırsat bulunca bakacağım. Bu arada müsait olan bir arkadaşımız kodları revize eder, size zaman kazandırırsa memnuniyet duyarım.

Teşekkür ederim hocam, dediğiniz gibi sıralamayı yapıyor. Her bayii'den 5 ürün seçimini dört gözle bekliyorum. Çok sağolun.

 

[DMR 7]

Diğer ayrıntılar (her bayiden 5 ürün alımı) için fırsat bulunca bakacağım.

Bu arada bayii başına ürün sayısı, çeşitliliği, bayii sayısı veya adı değiştiğinde de aynı kodlar çalışır değil mi? Yoksa herhangi bir kod değiştirilmeli mi? Dinamik olsa çok güzel olur.

Hocam, bu kodları linkteki dosyada bulunan "Sıralı Liste" sayfasında çalıştırsak ve 5'erli seçim sonuçlarını "Oluşacak Liste"ye bayi bazında aktarsak olabilir mi? Tabi önemli bir husus var, bayii sayısı değişebilir, yani kaç farklı bayii varsa "Oluşacak Liste" sayfasında o kadar bayii oluşturup veri dökse?

http://s5.dosya.tc/server5/sna8j8/Bayii_Urun_Listesi.rar.html

Hocam algoritmik veya mantıksal herhangi bir sorun olur mu bilemiyorum ancak yapmak istediğim tam olarak şu;

1. Bayii'de, tüm listeye göre benzersiz ürün varsa, en başta o benzersizleri pahalılık sırasına göre 5 ürün olana kadar yerleştir. Bir bayiide 5'ten fazla benzersiz ürün varsa en fazla 5 adet ürün yerleştir. Yerleştirilen ürün sayısı 5 olursa bayiyi yerleştirmeye kapat. 5 Olmazsa sıradaki adıma geç.

2. Tüm liste içerisinde kaç çeşit ürün varsa listele. Daha önce yerleştirdiğin ve 5'den fazla olduğu için yerleştirilemeyen benzersizleri bu listeden çıkar. Listede kalan ürünleri tüm listedeki sıklık değerine göre küçükten büyüğe doğru sırala. Listede sıklığı en az olandan başlayarak ürünleri yerleştirmeye başla.

3. Daha sonra her ürün çeşidi için en pahalı hangi bayideyse, git o bayiye yerleştir. Bayiideki ürün sayısı 5 olursa o bayiyi yerleştirmeye kapat. Ürünün en pahalı olduğu bayii yerleştirmeye kapatılmışsa, en pahalıdan bir sonraki pahalı olan bayiiye yerleştir. Bunu tüm ürün çeşitleri yerleştirilene kadar tekrarla.

4. Tüm çeşitler yerleştirildikten sonra ürün sayısı 5'e tamamlanmayan bayilerde, kaç adet yerleştirilmeyen ürün varsa, yerleştirilen ürünler dışında o bayiide kalan en pahalı ürünleri yerleştir ve 5'e tamamla.

5. Toplam kaç farklı ürün yerleştirdiğini bir hücreye yaz.



Sonuç olarak; seçilecek bu 50 ürün içerisinde, 32 farklı ürünün 30 tanesinin yerleşmiş olması gerekiyor. Bayii 9'da 7 benzersiz ürün olduğu ve en fazla 5 tane yerleştirilebildiği için 30 farklı ürün oluyor. 2 tane ucuz olanı kalıyor.

 

[DMR 7]

Antonio sanırım müsait olamadı, başka yardım edebilecek herhangi biri var mı?

 

[muygun]

Merhaba;
Bir tablo oluşturdum ama isteğinizi karşılar mı bilemiyorum.
İnceleyin.
İyi çalışmalar.

Link:
http://www.dosya.tc/server10/19eskk/DMR_7-analiz.zip.html

 

[Korhan Ayhan]

OLUŞACAK LİSTE sayfasına olması gereken listeyi elle yazabilir misiniz?

En azından 9 nolu mesajınızda yazdığınız koşullar kafamızda şekillenir. Kodu hazırlamamız daha kolay olabilir.

 

[DMR 7]

Merhaba;
Bir tablo oluşturdum ama isteğinizi karşılar mı bilemiyorum.
İnceleyin.
İyi çalışmalar.

Link:
http://www.dosya.tc/server10/19eskk/DMR_7-analiz.zip.html

Hocam, verileri okumakta zorlandım. Yaptığınızı çok kısa açıklar mısınız?

 

[DMR 7]

OLUŞACAK LİSTE sayfasına olması gereken listeyi elle yazabilir misiniz?

En azından 9 nolu mesajınızda yazdığınız koşullar kafamızda şekillenir. Kodu hazırlamamız daha kolay olabilir.

Günaydın hocam,

Manuel olarak düzenlemem biraz uzun sürdü sabah yeni hallettim, paylaşıyorum linki.

http://s6.dosya.tc/server11/gwrr38/Bayii_Urun_Listesi_Manuel_yerlestirme.rar.html

Daha anlaşılır olması açısından, ürün yerleştirme sayfasında yaptıklarımı sırasıyla yazdım hocam.

 

[DMR 7]

OLUŞACAK LİSTE sayfasına olması gereken listeyi elle yazabilir misiniz?

En azından 9 nolu mesajınızda yazdığınız koşullar kafamızda şekillenir. Kodu hazırlamamız daha kolay olabilir.

Hocam bu arada, makro dinamik olursa çok çok sevinirim.

Bayii başına ürün sayısı, çeşitliliği, bayii sayısı veya adı değiştiğinde de aynı kodlar çalışırsa memnun olurum.

 

[DMR 7]

Herhangi bir gelişme oldu mu

 

[Korhan Ayhan]

Merhaba,

Dosyanızı inceledim.

Bayii1 için listede 10 farklı benzersiz ürün kalıyor. Fakat siz dosyanızda 5 adet olarak belirtmişsiniz.

Bayii9 için listede 7 farklı benzersiz ürün kalıyor. Bunlardan ilk 5 adedi tabloya yerleştiriliyor. Geri kalan 2 adet ürün hiç dikkate alınmıyor.

Durum böyleyse Bayii1 deki 10 adet benzersiz ürünün kalan 5 adedi neden işleme dahil ediliyor. Olayın bu kısmı kafamda soru işareti oluşturuyor.

Şimdilik tasarladığım kod aşağıdaki gibidir.

Kod sizin tarif ettiğiniz işlemleri yapıyor. Son olarak yukarıdaki anlattığım durum kaldı. Ona da açıklama yaparsanız koda ekleme yapabilirim.

Option Explicit

Sub BAYİ_ÜRÜN_LİSTESİ_HAZIRLA()
    Dim S1 As Worksheet, S2 As Worksheet, S3 As Worksheet
    Dim Ürün_Sayısı As Integer, X As Long, Bul As Range, Adres As String
    Dim Son As Long, Satır As Long
    
    Set S1 = Sheets("Tüm Listeler")
    Set S2 = Sheets("Oluşacak Liste")
    Set S3 = Sheets("Sıralı Liste")
    
    Ürün_Sayısı = Application.InputBox("Lütfen bayii başına kaç adet ürün listelemek istediğinizi giriniz.", "ÜRÜN ADEDİ BELİRLEME", 5)
    If Ürün_Sayısı = Empty Or Ürün_Sayısı = False Then Exit Sub
    
    S2.Cells.Clear
    S3.Cells.Clear
    
    S2.Range("A1") = "Sıra No"
    S2.Range("A1:A2").Merge
    S2.Range("A3") = 1
    S2.Range("A3").AutoFill Destination:=S2.Range("A3:A" & Ürün_Sayısı + 2), Type:=xlFillSeries
    S2.Cells.VerticalAlignment = xlCenter
    With S2.Range("A1:A" & Ürün_Sayısı + 2)
        .Font.Bold = True
        .Borders.LineStyle = 1
        .HorizontalAlignment = xlCenter
        .Interior.ColorIndex = 4
    End With
    
    With S3.Range("A1:D1")
        .Value = Array("BAYİİ NO", "TÜR", "FİYAT", "SIKLIK")
        .HorizontalAlignment = xlCenter
        .Font.Bold = True
    End With
        
    For X = 2 To S1.Cells(1, S1.Columns.Count).End(1).Column Step 2
        If S1.Cells(3, X) <> "" Then
            S1.Cells(1, X).Resize(Ürün_Sayısı + 2, 2).Copy S2.Cells(1, X)
            S2.Cells(3, X).Resize(Ürün_Sayısı, 2).ClearContents
            S2.Cells(1, X).Resize(Ürün_Sayısı + 2, 2).Interior.Color = S1.Cells(1, X).Interior.Color
        
            Son = S1.Cells(S1.Rows.Count, X).End(3).Row - 2
            Satır = S3.Cells(S3.Rows.Count, 1).End(3).Row + 1
            S1.Cells(3, X).Resize(Son, 2).Copy S3.Cells(Satır, 2)
            S3.Range("A" & Satır & ":A" & Satır + Son - 1) = S1.Cells(1, X)
        End If
    Next
    
    Son = S3.Cells(S3.Rows.Count, 1).End(3).Row
    
    With S3.Range("D2:D" & Son)
        .Formula = "=COUNTIF(B:B,B2)"
        .Value = .Value
    End With
    
    With S3.Range("A1:D" & Son)
        .Sort S3.Range("D1"), xlAscending, S3.Range("C1"), , xlDescending, S3.Range("B1"), xlAscending, xlYes
        .RemoveDuplicates Columns:=2, Header:=xlYes
    End With

'    Son = S3.Cells(S3.Rows.Count, 1).End(3).Row
'
'    For X = Son To 2 Step -1
'        If WorksheetFunction.CountIf(S3.Range("A:A"), S3.Cells(X, 1)) > Ürün_Sayısı Then
'            S3.Rows(X).Delete
'        End If
'    Next
    
    Son = S2.Cells(1, S3.Columns.Count).End(1).Column

    For X = 2 To Son Step 2
        Set Bul = S3.Range("A:A").Find(S2.Cells(1, X), , , xlWhole)
        If Not Bul Is Nothing Then
            Adres = Bul.Address
            Do
                If Bul.Offset(0, 4) <> "X" Then
                    Satır = S2.Cells(S2.Rows.Count, X).End(3).Row + 1
                    If (Satır - 2) > Ürün_Sayısı Then Exit Do
                    S2.Cells(Satır, X) = Bul.Offset(0, 1)
                    S2.Cells(Satır, X + 1) = Bul.Offset(0, 2)
                    Bul.Offset(0, 4) = "X"
                End If
                Set Bul = S3.Range("A:A").FindNext(Bul)
            Loop While Not Bul Is Nothing And Bul.Address <> Adres
        End If
    Next

    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub

 

[DMR 7]

Merhaba,

Dosyanızı inceledim.

Bayii1 için listede 10 farklı benzersiz ürün kalıyor. Fakat siz dosyanızda 5 adet olarak belirtmişsiniz.

Bayii9 için listede 7 farklı benzersiz ürün kalıyor. Bunlardan ilk 5 adedi tabloya yerleştiriliyor. Geri kalan 2 adet ürün hiç dikkate alınmıyor.

Durum böyleyse Bayii1 deki 10 adet benzersiz ürünün kalan 5 adedi neden işleme dahil ediliyor. Olayın bu kısmı kafamda soru işareti oluşturuyor.

Şimdilik tasarladığım kod aşağıdaki gibidir.

Kod sizin tarif ettiğiniz işlemleri yapıyor. Son olarak yukarıdaki anlattığım durum kaldı. Ona da açıklama yaparsanız koda ekleme yapabilirim.

Option Explicit

Sub BAYİ_ÜRÜN_LİSTESİ_HAZIRLA()
    Dim S1 As Worksheet, S2 As Worksheet, S3 As Worksheet
    Dim Ürün_Sayısı As Integer, X As Long, Bul As Range, Adres As String
    Dim Son As Long, Satır As Long
    
    Set S1 = Sheets("Tüm Listeler")
    Set S2 = Sheets("Oluşacak Liste")
    Set S3 = Sheets("Sıralı Liste")
    
    Ürün_Sayısı = Application.InputBox("Lütfen bayii başına kaç adet ürün listelemek istediğinizi giriniz.", "ÜRÜN ADEDİ BELİRLEME", 5)
    If Ürün_Sayısı = Empty Or Ürün_Sayısı = False Then Exit Sub
    
    S2.Cells.Clear
    S3.Cells.Clear
    
    S2.Range("A1") = "Sıra No"
    S2.Range("A1:A2").Merge
    S2.Range("A3") = 1
    S2.Range("A3").AutoFill Destination:=S2.Range("A3:A" & Ürün_Sayısı + 2), Type:=xlFillSeries
    S2.Cells.VerticalAlignment = xlCenter
    With S2.Range("A1:A" & Ürün_Sayısı + 2)
        .Font.Bold = True
        .Borders.LineStyle = 1
        .HorizontalAlignment = xlCenter
        .Interior.ColorIndex = 4
    End With
    
    With S3.Range("A1:D1")
        .Value = Array("BAYİİ NO", "TÜR", "FİYAT", "SIKLIK")
        .HorizontalAlignment = xlCenter
        .Font.Bold = True
    End With
        
    For X = 2 To S1.Cells(1, S1.Columns.Count).End(1).Column Step 2
        If S1.Cells(3, X) <> "" Then
            S1.Cells(1, X).Resize(Ürün_Sayısı + 2, 2).Copy S2.Cells(1, X)
            S2.Cells(3, X).Resize(Ürün_Sayısı, 2).ClearContents
            S2.Cells(1, X).Resize(Ürün_Sayısı + 2, 2).Interior.Color = S1.Cells(1, X).Interior.Color
        
            Son = S1.Cells(S1.Rows.Count, X).End(3).Row - 2
            Satır = S3.Cells(S3.Rows.Count, 1).End(3).Row + 1
            S1.Cells(3, X).Resize(Son, 2).Copy S3.Cells(Satır, 2)
            S3.Range("A" & Satır & ":A" & Satır + Son - 1) = S1.Cells(1, X)
        End If
    Next
    
    Son = S3.Cells(S3.Rows.Count, 1).End(3).Row
    
    With S3.Range("D2:D" & Son)
        .Formula = "=COUNTIF(B:B,B2)"
        .Value = .Value
    End With
    
    With S3.Range("A1:D" & Son)
        .Sort S3.Range("D1"), xlAscending, S3.Range("C1"), , xlDescending, S3.Range("B1"), xlAscending, xlYes
        .RemoveDuplicates Columns:=2, Header:=xlYes
    End With

'    Son = S3.Cells(S3.Rows.Count, 1).End(3).Row
'
'    For X = Son To 2 Step -1
'        If WorksheetFunction.CountIf(S3.Range("A:A"), S3.Cells(X, 1)) > Ürün_Sayısı Then
'            S3.Rows(X).Delete
'        End If
'    Next
    
    Son = S2.Cells(1, S3.Columns.Count).End(1).Column

    For X = 2 To Son Step 2
        Set Bul = S3.Range("A:A").Find(S2.Cells(1, X), , , xlWhole)
        If Not Bul Is Nothing Then
            Adres = Bul.Address
            Do
                If Bul.Offset(0, 4) <> "X" Then
                    Satır = S2.Cells(S2.Rows.Count, X).End(3).Row + 1
                    If (Satır - 2) > Ürün_Sayısı Then Exit Do
                    S2.Cells(Satır, X) = Bul.Offset(0, 1)
                    S2.Cells(Satır, X + 1) = Bul.Offset(0, 2)
                    Bul.Offset(0, 4) = "X"
                End If
                Set Bul = S3.Range("A:A").FindNext(Bul)
            Loop While Not Bul Is Nothing And Bul.Address <> Adres
        End If
    Next

    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub

Merhabalar Korhan Hocam,

Hocam makro sonucu ile benim manuel yerleştirdiklerim tamamen uyuşuyor. Fakat yerleşmeyenler olmuş.

Bayii 6'da dosya3
Bayii 8'de silgi4
Bayi 10'da ise, silgi1-defter1-dosya1

Bir de çeşitler yerleştikten sonra bayiler 5 ürüne tamamlanmamış, kalan en pahalılar ile.

 

[DMR 7]

Bayii1 için listede 10 farklı benzersiz ürün kalıyor. Fakat siz dosyanızda 5 adet olarak belirtmişsiniz.

Bayii9 için listede 7 farklı benzersiz ürün kalıyor. Bunlardan ilk 5 adedi tabloya yerleştiriliyor. Geri kalan 2 adet ürün hiç dikkate alınmıyor.

Durum böyleyse Bayii1 deki 10 adet benzersiz ürünün kalan 5 adedi neden işleme dahil ediliyor. Olayın bu kısmı kafamda soru işareti oluşturuyor.

Bayii9'daki kalan 2 ürün hiçbir bayii'de olmadığı için dikkate alınmıyor. Eğer o 2'si herhangi bir bayii'de olsa idi, onları da yerleştirmeye çalışacaktım. Kota 5 olduğundan dolayı mecburen 2'si dışarda kalıyor.

Bayii 1 için benzersizden kastım; başka hiçbir bayii'de olmayan sadece bayii 1'de olan ürünlerdi. Onlarda sıklık değeri 1 olan, sonunda "5" olan ürünlerdi. Diğer yerleşmeyen 5 ürün (dosya3-silgi4-silgi1-defter1-dosya1) benzersiz değil. Sadece en pahalı bayii 1 de satılıyor. Onlar diğer bayiilere dağıtılabilir.

Amacım yerleştirilecek bu 50 ürün içerisinde yapabileceğim en fazla ürün türünü oluşturmak olduğundan, bayii 1'de olup yerleşmeyenler ürünleri (dosya3-silgi4-silgi1-defter1-dosya1) diğer bayii'lere dağıtmak. ( pahalılık koşulu ile)

Emekleriniz için çok teşekkür ediyorum. Zaten çok büyük bir kısmı bitmiş durumda. Sanırım daha kolay kısmı kaldı.

Sıklığı en az olan, üründen başlayarak yerleştirilmemiş tüm çeşitleri yerleştirmek istiyorum.
Dediğiniz gibi bazı bayilerde 5 adet ürün yerleşmiş ve hala en pahalı ürünlere sahip olabilirler.
O ürünleri de o bayii'den sonra hangi bayii de daha pahalı satılıyorsa oraya yerleştirmek istiyorum.
O ürünü 2. en pahalı satan bayiinin de 5 ürünü yerleşti diyelim.
O zaman 3. en pahalıya. O da 5 ürün ile mi dolu? O zaman 4. en pahalıya..
Ta ki ürün yerleşene kadar veya yerleşebilecek bayiisi bitene dek. Eğer yerleşecek herhangi bir bayii bulamazsa o ürün türünü yerleştiremeyeceğiz zaten.

Bayii 9'da olan da tam olarak bu.

Oraya en pahalı 5 ürünü yerleştirdik. Yerleşmeyen 2 ürün kaldı. Soruyoruz daha pahalı hangi bayii de bu ürün var? Cevap hiçbiri. O yüzden dikkate almıyoruz.

Fakat Bayii 1 için durum aynı değil.

Kalan yerleşmemiş ürünlere dönüp aynı soruyu sorduğumuzda, başka bayiilere yerleşebilecek.

Tüm çeşitler yerleştirildikten sonra ise, yerleşen ürün sayısı 5'den az olan bayiileri, o bayii bazında yerleşmemiş ürünlerin en pahalılarıyla 5'e tamamlıyoruz.

Umarım açıklayabilmişimdir.

 

[DMR 7]

son durum nedir?