Yerleştirme Ölçütlerinin Revize Edilmesi

DMR 7 · 26 Mart 2018

Merhaba Arkadaşlar,

Aşağıdaki konu ile ilgili yardımcı olabilir misiniz?

Kodlar sayesinde kişi başı 5 yerleştirme yapılıyor. (seçimli)

"Sıralı Liste" sayfasına sıklığı en az olandan fazla olana doğru bir sıralama yapıp, yerleştirme yapıyor şuanda.

Sıklık olayına hiç girmeden, sayfadaki seviye kısmını, büyükten küçüğe sıralayarak yerleştirme yaptırabilir misiniz?

dosya linki : http://s3.dosya.tc/server14/pj6xxo/Savas_Grubu_3.zip.html

Dip Not : Sayın Plint ve Korhan Bey'e teşekkürlerimi iletiyorum.

alicimri · 26 Mart 2018

Sn.DMR 7
İşinizi zorlaştırmışsınız. "Tüm Listeler" sayfanızı;
Grup Üyeleri'ne göre yan yana değil de,
Grup Üyeleri, KAHRAMANLAR, SEVİYE şeklinde alt alta yazsaydınız.
Sonuca kolay giderdiniz.

DMR 7 · 26 Mart 2018

alicimri' Alıntı:
Sn.DMR 7
İşinizi zorlaştırmışsınız. "Tüm Listeler" sayfanızı;
Grup Üyeleri'ne göre yan yana değil de,
Grup Üyeleri, KAHRAMANLAR, SEVİYE şeklinde alt alta yazsaydınız.
İlk önce KAHRAMANLAR'a göre A-Z sonra SEVİYE'ye göre Küçükten büyüğe göre sıralatıp, Grup Üyeleri'nin alt alta gelmesini sağlardınız.

Sn. AliCimri Bey, ilginiz için teşekkür ederim. normalde şuan ki düzen bir başka amaç için tasarlandı ve en çok çeşidi sağlıyor. Alt alta yazmamamdaki sebep ise, bu taslak dosyanın gerektiğinde rahat revize edilebilmesi, kişi başı girilen verilerin satırlarının sabit olmamasından dolayı idi.

Daha önce özel filtreleme ile tek tek manuel yapmıştım böyle bir şey, yerleştirdikçe yerleşmiş kahramanları sile sile ilerliyordum.
İstediğim sizin yaptığınız değil aslında.

-----

Kişi başı 5 kahraman olacak.

Seviyesi büyük olandan itibaren seçilmeye başlanacak.

ve en fazla çeşit amaçlandığından, birine yazılan kahraman bir diğerine yazılmayacak. (mecburen yazılamayacak kahraman kalmaz ise en yükseği seçilerek duallik oluşturulabilecek.)

bu yukarıda söylediğimin çoğu makro içinde mevcut sadece yerleşim ölçütünü kodlarda revize edersek oto olarak, oluşacak liste sayfasında görsel bir tablo oluşturabilecek.

DMR 7 · 26 Mart 2018

Yardım edebilecek herhangi biri var mı? "oluşacak liste" sayfasına yerleştirme yapmadan önce, seviye sütununa büyükten küçüğe sıralama gelmesini istiyorum ama nasıl yapacağımı bilmiyorum.

DMR 7 · 27 Mart 2018

Sorduğum yapılması zor birşey mi? öyle birşey ise ısrar etmeyeyim, bilen anlayan var mı?

Korhan Ayhan · 27 Mart 2018

Merhaba,

Bu konuyu hatırlıyorum. Fakat nasıl kurgu yaptığımızı anımsayamadım.

İstediğiniz sıralama yapıldıktan sonra verileriniz "Oluşacak Liste" sayfasında nasıl bir sonuç oluşacak? Bunu örneklerseniz sonuca daha kolay gidilebilir.

DMR 7 · 28 Mart 2018

Korhan Ayhan' Alıntı:
Merhaba,

Bu konuyu hatırlıyorum. Fakat nasıl kurgu yaptığımızı anımsayamadım.

İstediğiniz sıralama yapıldıktan sonra verileriniz "Oluşacak Liste" sayfasında nasıl bir sonuç oluşacak? Bunu örneklerseniz sonuca daha kolay gidilebilir.

Korhan hocam aslında tam olarak yapmak istediğim şu.

1. tüm kahramanları resimdeki gibi seviye başlığında büyükten küçüğe sıralamak.

2. Daha sonra tek tek her kişiye 5 kahraman oluncaya kadar yerleşim yapmak.

3. Yerleşim yaparken, en fazla kahraman yerleştirmek amaçlandığı için. kahraman seviyesi, en yüksek kimdeyse yerleştirip, bir sonrakine geçmek.

4. herhangi biri 5 kahramana ulaştı ise, onu tüm listelerden çıkarmak. yani o 5 kahramanı dolan kişisiz yeni bir sıralama yapmak.

- sarıyla boyanmış satırda tam olarak bu karşımıza çıkıyor. Hector88'e 5 kahraman yerleşti. Electro hala üst sıralarda görünüyor. halbuki elektronun en büyük olduğu ikinci kişi 25iso ve puanı 4638. artık bu puan ile aşağıda sıralamaya gitmesi gerekiyor ki, gidip 25iso ya düşük kahraman yerleştirmeyelim.

yani yerleştirme yaparken güncelleyen bir sistemle devam etmek gerekiyor aslında.

bu şekilde aşağıya doğru tüm kahramanları güncelleye güncelleye yerleştirdik ve hala tüm grup üyelerinde 5 kahramanı dolmayan var mesela. buradan sonra ki adım da şu.

6- artık eksik kalan kişilere kendi listesindeki en yüksek seviyeli kahramanların yerleştirilmesi. çünkü daha fazla çeşit yapılamayacak artık. 2. amacımız olan en yüksek seviyeyi sağlamak istiyoruz.

bu da o sarı satıra kadar ki yerleşim.

electro sıralamada aşağıya gittiği için, 25iso'ya fırtına yerlşecek bir sonraki adımda. ve artık 25iso 'ya da 5 kahraman yerleştiği için sıralamadan o da çıkarılacak. liste revize edilecek.

ibrahime daha önce sıralamadan çıkmıştı zaten bu düzende.

DMR 7 · 28 Mart 2018

Ben bunu manuel olarak şöyle yapmıştım. tüm listeler sayfasındakilerin hepsini alt alta yazıp seviyeye göre büyükten küçüğe sıraladım.

daha sonra yerleştirdiğim bir kahraman varsa, aşağıya doğru inen bu listede o kahramana ait tüm kayıtları filtre ile çıkardım. yerleştirmeye devam ettim.

herhangi birine 5 kahraman yerleştiyse, filtre ile bu kişinin tüm kayıtlarını listeden çıkardım. yerleştirmeye devam ettim.

bu şekilde filtreleyerek gittiğimde sürekli en üsttekini yerleştiriyordum.

bu şekilde filtreleme sonucu o liste sıfırlanana kadar devam ettim.

daha sonra yerleşmesi eksik kalanlar oldu. çünkü yeterli çeşit sağlanamadı.

filtre ile sadece o yerleşimi eksik kalan kişiyi seçtim. ona mesela 2 kahraman yerleştiyse onları aradan çıkardım. ve kalan 3 kahramanı çeşide bakmaksızın en yüksek puanlılardan koydum.

bu benim tamamen manuel yaptığım birşeydi.

DMR 7 · 30 Mart 2018

anlaşılmayan yer olur ise açabilirim

DMR 7 · 2 Nisan 2018

+ 1 ???

DMR 7 · 6 Nisan 2018

konu günceldir

Korhan Ayhan · 27 Nisan 2018

Aşağıdaki kodu deneyiniz.

Kod:

Option Explicit

Sub SAVUNMA_LİSTESİ_HAZIRLA()
    Dim S1 As Worksheet, S2 As Worksheet, S3 As Worksheet, WF As WorksheetFunction
    Dim Kahraman_Sayısı As Integer, X As Long, Bul As Range, Adres As String, Z As Long
    Dim Son As Long, Satır As Long, Say As Long, Bayi As Variant, Y As Long
    
    Set S1 = Sheets("Tüm Listeler")
    Set S2 = Sheets("Oluşacak Liste")
    Set S3 = Sheets("Sıralı Liste")
    Set WF = WorksheetFunction
    
    Kahraman_Sayısı = Application.InputBox("Lütfen kişi başına kaç adet kahraman seçmek istediğinizi giriniz.", "KAHRAMAN ADEDİ BELİRLEME", 5)
    If Kahraman_Sayısı = Empty Or Kahraman_Sayısı = False Then Exit Sub
    
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    
    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" & Kahraman_Sayısı + 2), Type:=xlFillSeries
    S2.Cells.VerticalAlignment = xlCenter
    With S2.Range("A1:A" & Kahraman_Sayısı + 2)
        .Font.Bold = True
        .Borders.LineStyle = 1
        .HorizontalAlignment = xlCenter
        .Interior.ColorIndex = 4
    End With
    
    With S3.Range("A1:F1")
        .Value = Array("Grup Üyeleri", "KAHRAMANLAR", "SEVİYE", "SIKLIK", "KONTROL", "SEVİYE SIRALAMASI")
        .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(Kahraman_Sayısı + 2, 2).Copy S2.Cells(1, X)
            S2.Cells(3, X).Resize(Kahraman_Sayısı, 2).ClearContents
            S2.Cells(1, X).Resize(Kahraman_Sayısı + 2, 2).Interior.Color = S1.Cells(1, X).Interior.Color
            S2.Cells(1, X).Resize(Kahraman_Sayısı + 2, 2).Borders.LineStyle = 1
            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).Sort S1.Cells(3, X + 1), xlDescending
            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("A1:D" & Son)
        .Sort S3.Range("C1"), xlDescending, , , xlYes
    End With
    
    Son = S2.Cells(1, S2.Columns.Count).End(1).Column
    
    For X = 2 To Son Step 2
        Say = WorksheetFunction.CountIf(S3.Range("A:A"), S2.Cells(1, X))
        If Say >= 1 Then
            Set Bul = S3.Range("A:A").Find(S2.Cells(1, X), , , xlWhole)
            If Not Bul Is Nothing Then
                Adres = Bul.Address
                Do
                    Satır = S2.Cells(S2.Rows.Count, X).End(3).Row + 1
                    If (Satır - 2) > Kahraman_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"
                    Set Bul = S3.Range("A:A").FindNext(Bul)
                Loop While Not Bul Is Nothing And Bul.Address <> Adres
            End If
        End If
    Next
    
    S2.Cells.EntireColumn.AutoFit
    Son = S2.Cells(S2.Rows.Count, 2).End(3).Row
    S2.Cells(Son + 3, 2) = "TOPLAM ÇEŞİT SAYISI"
    S2.Cells(Son + 4, 2) = "YERLEŞTİRİLEN ÇEŞİT SAYISI"
    S2.Cells(Son + 3, 5) = S3.Cells(S3.Rows.Count, 1).End(3).Row - 1
    S2.Cells(Son + 4, 5) = WorksheetFunction.CountIf(S3.Range("E:E"), "X")
    S2.Range("B" & Son + 3 & ":D" & Son + 3).Merge
    S2.Range("B" & Son + 4 & ":D" & Son + 4).Merge
    S2.Range("B" & Son + 3 & ":E" & Son + 4).Font.Bold = True
    S2.Range("B" & Son + 3 & ":E" & Son + 4).Borders.LineStyle = 1

    Set Bul = Nothing
    Set WF = Nothing
    Set S1 = Nothing
    Set S2 = Nothing
    Set S3 = Nothing

    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic

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

DMR 7 · 4 Mayıs 2018

Korhan Ayhan' Alıntı:

Aşağıdaki kodu deneyiniz.

Kod:

Option Explicit

Sub SAVUNMA_LİSTESİ_HAZIRLA()
    Dim S1 As Worksheet, S2 As Worksheet, S3 As Worksheet, WF As WorksheetFunction
    Dim Kahraman_Sayısı As Integer, X As Long, Bul As Range, Adres As String, Z As Long
    Dim Son As Long, Satır As Long, Say As Long, Bayi As Variant, Y As Long
    
    Set S1 = Sheets("Tüm Listeler")
    Set S2 = Sheets("Oluşacak Liste")
    Set S3 = Sheets("Sıralı Liste")
    Set WF = WorksheetFunction
    
    Kahraman_Sayısı = Application.InputBox("Lütfen kişi başına kaç adet kahraman seçmek istediğinizi giriniz.", "KAHRAMAN ADEDİ BELİRLEME", 5)
    If Kahraman_Sayısı = Empty Or Kahraman_Sayısı = False Then Exit Sub
    
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    
    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" & Kahraman_Sayısı + 2), Type:=xlFillSeries
    S2.Cells.VerticalAlignment = xlCenter
    With S2.Range("A1:A" & Kahraman_Sayısı + 2)
        .Font.Bold = True
        .Borders.LineStyle = 1
        .HorizontalAlignment = xlCenter
        .Interior.ColorIndex = 4
    End With
    
    With S3.Range("A1:F1")
        .Value = Array("Grup Üyeleri", "KAHRAMANLAR", "SEVİYE", "SIKLIK", "KONTROL", "SEVİYE SIRALAMASI")
        .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(Kahraman_Sayısı + 2, 2).Copy S2.Cells(1, X)
            S2.Cells(3, X).Resize(Kahraman_Sayısı, 2).ClearContents
            S2.Cells(1, X).Resize(Kahraman_Sayısı + 2, 2).Interior.Color = S1.Cells(1, X).Interior.Color
            S2.Cells(1, X).Resize(Kahraman_Sayısı + 2, 2).Borders.LineStyle = 1
            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).Sort S1.Cells(3, X + 1), xlDescending
            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("A1:D" & Son)
        .Sort S3.Range("C1"), xlDescending, , , xlYes
    End With
    
    Son = S2.Cells(1, S2.Columns.Count).End(1).Column
    
    For X = 2 To Son Step 2
        Say = WorksheetFunction.CountIf(S3.Range("A:A"), S2.Cells(1, X))
        If Say >= 1 Then
            Set Bul = S3.Range("A:A").Find(S2.Cells(1, X), , , xlWhole)
            If Not Bul Is Nothing Then
                Adres = Bul.Address
                Do
                    Satır = S2.Cells(S2.Rows.Count, X).End(3).Row + 1
                    If (Satır - 2) > Kahraman_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"
                    Set Bul = S3.Range("A:A").FindNext(Bul)
                Loop While Not Bul Is Nothing And Bul.Address <> Adres
            End If
        End If
    Next
    
    S2.Cells.EntireColumn.AutoFit
    Son = S2.Cells(S2.Rows.Count, 2).End(3).Row
    S2.Cells(Son + 3, 2) = "TOPLAM ÇEŞİT SAYISI"
    S2.Cells(Son + 4, 2) = "YERLEŞTİRİLEN ÇEŞİT SAYISI"
    S2.Cells(Son + 3, 5) = S3.Cells(S3.Rows.Count, 1).End(3).Row - 1
    S2.Cells(Son + 4, 5) = WorksheetFunction.CountIf(S3.Range("E:E"), "X")
    S2.Range("B" & Son + 3 & ":D" & Son + 3).Merge
    S2.Range("B" & Son + 4 & ":D" & Son + 4).Merge
    S2.Range("B" & Son + 3 & ":E" & Son + 4).Font.Bold = True
    S2.Range("B" & Son + 3 & ":E" & Son + 4).Borders.LineStyle = 1

    Set Bul = Nothing
    Set WF = Nothing
    Set S1 = Nothing
    Set S2 = Nothing
    Set S3 = Nothing

    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic

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

Korhan hocam çeşit yapmıyor yalnız bu. direk kişi başı en yüksek 5 taneyi yerleştirmiş.

konudaki 7. mesajda anlatmaya çalıştığım gibi değil.

http://www.excel.web.tr/f48/yerle-tirme-lcutlerinin-revize-edilmesi-t171634/post936345.html

DMR 7 · 11 Haziran 2018

Yardım edebilecek kimse yok mudur?

DMR 7 · 11 Haziran 2018

konu hala netliğe kavuşmuş değil.

DMR 7 · 12 Haziran 2018

günceldir...

DMR 7 · 13 Haziran 2018

manuel yerleşim : http://s3.dosya.tc/server16/s37hvd/Savas_Grubu_3_-_Manuel_Yerlestirme.rar.html

DMR 7 · 20 Haziran 2018

konu gerilerde kalmış

PLİNT · 20 Haziran 2018

Merhaba
Ek dosyayı deneyin

Kod:

Private Sub CommandButton1_Click()
Dim f As Long, a As Long, f2 As Long, v As Range, r As Range, r2 As Long, son As Long
Dim s3r As Long, k As Long, urun As Long, c As Long, i As Long, TPL As Long
Dim S1 As Worksheet, S2 As Worksheet, S3 As Worksheet, WF As WorksheetFunction
    Dim Ürün_Sayısı As Integer
        Dim dict As Object
Set dict = CreateObject("Scripting.Dictionary")
    Set S1 = Sheets("Tüm Listeler")
    Set S2 = Sheets("Oluşacak Liste")
    Set S3 = Sheets("Sıralı Liste")
    Set WF = WorksheetFunction
    Ürün_Sayısı = Application.InputBox("Lütfen kişi başına kaç adet kahraman seçmek istediğinizi giriniz.", "KAHRAMAN ADEDİ BELİRLEME", 5)
    If Ürün_Sayısı = Empty Or Ürün_Sayısı = False Then Exit Sub
   S2.Cells.Clear
   f = 2: f2 = 1
For a = 2 To S1.Cells(1, Columns.Count).End(xlToLeft).Column
S1.Range(S1.Cells(1, a), S1.Cells(2 + Ürün_Sayısı, a + 1)).Copy S2.Cells(f2, f)
f = f + 3: a = a + 1: i = i + 1
If WF.CountIf(S2.Rows(f2), "> ") = 5 Then
f2 = S2.Cells.Find("*", SearchOrder:=xlByRows, searchdirection:=xlPrevious).Row + 3
S2.Rows((f2 - Ürün_Sayısı) - 2 & ":" & (f2) - 3) = Empty
S2.Rows((f2 - Ürün_Sayısı) - 2 & ":" & (f2) - 3).Validation.Delete
f = 2
End If
Next
S2.Range("B:B,E:E,H:H,K:K,N:N").ColumnWidth = 25
S2.Range("C:C,F:F,I:I,L:L,O:O").ColumnWidth = 10
S2.Range("D:D,G:G,J:J,M:M").ColumnWidth = 7
S3.Range("A2:F" & Rows.Count).Clear
For Each v In S1.Range(S1.Cells(3, 2), S1.Cells(Rows.Count, S1.Cells(1, Columns.Count).End(xlToLeft).Column)).SpecialCells(xlCellTypeConstants, 2).Cells
s3r = S3.Cells(Rows.Count, "A").End(3).Row
S3.Cells(s3r + 1, "A") = S1.Cells(1, v.Column).Value
S3.Cells(s3r + 1, "B") = v.Value
S3.Cells(s3r + 1, "C") = S1.Cells(v.Row, v.Column + 1).Value
Next
S3.Range("A2:C" & s3r + 1).Sort Key1:=S3.Cells(2, 3), Order1:=xlDescending
s3r = S3.Cells(Rows.Count, "A").End(3).Row
c = 0
S2.Activate
10:
For a = 2 To s3r
If WF.CountIf(S3.Range("E2:E" & s3r), S3.Cells(a, "A")) <= Ürün_Sayısı - 1 And WF.CountIf(S3.Range("D2:D" & s3r), S3.Cells(a, "B")) = 0 And _
S3.Cells(a, "F") = "" Then
Set r = S2.Cells.Find(S3.Cells(a, "A").Value, , , xlWhole)
If r Is Nothing Then MsgBox S3.Cells(a, "A").Value & " " & S2.Name & " Sayfasında bulunamadı. İşlem sonlandırılacak": Exit Sub
r2 = S2.Cells(r.Row + Ürün_Sayısı + 2, r.Column).End(3).Row
S2.Cells(r2 + 1, r.Column) = S3.Cells(a, "B").Value
If dict.Exists(S3.Cells(a, "B").Value) = False Then dict.Add S3.Cells(a, "B").Value, ""
S2.Cells(r2 + 1, r.Column + 1) = S3.Cells(a, "C").Value
TPL = TPL + S3.Cells(a, "C").Value
If r.Row + Ürün_Sayısı = r2 Then _
S2.Range(S2.Cells(r.Row + 2, r.Column), S2.Cells(r.Row + Ürün_Sayısı + 1, r.Column + 1)).Sort Key1:=S2.Cells(r.Row + 2, r.Column + 1), Order1:=xlDescending
S3.Cells(a, "D").Value = S3.Cells(a, "B").Value
S3.Cells(a, "E").Value = S3.Cells(a, "A").Value
S3.Cells(a, "F") = 1 + S3.Cells(a, "F")
End If
If WF.CountIf(S3.Range("B2:B" & a), S3.Cells(a, "B")) = 1 Then urun = urun + 1
Next
If Ürün_Sayısı * i > Application.Sum(S3.Range("F2:F" & s3r)) Then
S3.Range("D2:D" & s3r) = ""
c = c + 1: urun = 0: GoTo 10
End If
    son = S2.Cells.Find("*", SearchOrder:=xlByRows, searchdirection:=xlPrevious).Row
    S2.Cells(son + 3, 2) = "TOPLAM ÇEŞİT SAYISI"
    S2.Cells(son + 4, 2) = "YERLEŞTİRİLEN ÇEŞİT SAYISI"
    S2.Cells(son + 5, 2) = "TOPLAM"
    S2.Cells(son + 3, 5) = urun
    S2.Cells(son + 4, 5) = dict.Count
    S2.Cells(son + 5, 5) = TPL
  S2.Range("B" & son + 3 & ":D" & son + 3 & "," & "B" & son + 4 & ":D" & son + 4 & "," & "B" & son + 5 & ":D" & son + 5).Merge
    S2.Range("B" & son + 3 & ":E" & son + 5).Font.Bold = True
    S2.Range("B" & son + 3 & ":E" & son + 5).Borders.LineStyle = 1
End Sub

DMR 7 · 21 Haziran 2018

PLİNT' Alıntı:

Merhaba
Ek dosyayı deneyin
http://s3.dosya.tc/server16/8hx6tg/Savas_Grubu_deneme3.zip.html

Kod:

Private Sub CommandButton1_Click()
Dim f As Long, a As Long, f2 As Long, v As Range, r As Range, r2 As Long, son As Long
Dim s3r As Long, k As Long, urun As Long, c As Long, i As Long, TPL As Long
Dim S1 As Worksheet, S2 As Worksheet, S3 As Worksheet, WF As WorksheetFunction
    Dim Ürün_Sayısı As Integer
    Set S1 = Sheets("Tüm Listeler")
    Set S2 = Sheets("Oluşacak Liste")
    Set S3 = Sheets("Sıralı Liste")
    Set WF = WorksheetFunction
    Ürün_Sayısı = Application.InputBox("Lütfen kişi başına kaç adet kahraman seçmek istediğinizi giriniz.", "KAHRAMAN ADEDİ BELİRLEME", 5)
    If Ürün_Sayısı = Empty Or Ürün_Sayısı = False Then Exit Sub
   S2.Cells.Clear
   f = 2: f2 = 1
For a = 2 To S1.Cells(1, Columns.Count).End(xlToLeft).Column
S1.Range(S1.Cells(1, a), S1.Cells(2 + Ürün_Sayısı, a + 1)).Copy S2.Cells(f2, f)
f = f + 3: a = a + 1: i = i + 1
If WF.CountIf(S2.Rows(f2), "> ") = 5 Then
f2 = S2.Cells.Find("*", SearchOrder:=xlByRows, searchdirection:=xlPrevious).Row + 3
S2.Rows((f2 - Ürün_Sayısı) - 2 & ":" & (f2) - 3) = Empty
S2.Rows((f2 - Ürün_Sayısı) - 2 & ":" & (f2) - 3).Validation.Delete
f = 2
End If
Next
S2.Range("B:B,E:E,H:H,K:K,N:N").ColumnWidth = 25
S2.Range("C:C,F:F,I:I,L:L,O:O").ColumnWidth = 10
S2.Range("D:D,G:G,J:J,M:M").ColumnWidth = 7
S3.Range("A2:F" & Rows.Count).Clear
For Each v In S1.Range(S1.Cells(3, 2), S1.Cells(Rows.Count, S1.Cells(1, Columns.Count).End(xlToLeft).Column)).SpecialCells(xlCellTypeConstants, 2).Cells
s3r = S3.Cells(Rows.Count, "A").End(3).Row
S3.Cells(s3r + 1, "A") = S1.Cells(1, v.Column).Value
S3.Cells(s3r + 1, "B") = v.Value
S3.Cells(s3r + 1, "C") = S1.Cells(v.Row, v.Column + 1).Value
Next
S3.Range("A2:C" & s3r + 1).Sort Key1:=S3.Cells(2, 3), Order1:=xlDescending
s3r = S3.Cells(Rows.Count, "A").End(3).Row
c = 0
S2.Activate
10:
For a = 2 To s3r
If WF.CountIf(S3.Range("E2:E" & s3r), S3.Cells(a, "A")) <= Ürün_Sayısı - 1 And WF.CountIf(S3.Range("D2:D" & s3r), S3.Cells(a, "B")) = 0 And _
S3.Cells(a, "F") = "" Then
Set r = S2.Cells.Find(S3.Cells(a, "A").Value, , , xlWhole)
If r Is Nothing Then MsgBox S3.Cells(a, "A").Value & " " & S2.Name & " Sayfasında bulunamadı. İşlem sonlandırılacak": Exit Sub
r2 = S2.Cells(r.Row + Ürün_Sayısı + 2, r.Column).End(3).Row
S2.Cells(r2 + 1, r.Column) = S3.Cells(a, "B").Value
S2.Cells(r2 + 1, r.Column + 1) = S3.Cells(a, "C").Value
TPL = TPL + S3.Cells(a, "C").Value
If r.Row + Ürün_Sayısı = r2 Then _
S2.Range(S2.Cells(r.Row + 2, r.Column), S2.Cells(r.Row + Ürün_Sayısı + 1, r.Column + 1)).Sort Key1:=S2.Cells(r.Row + 2, r.Column + 1), Order1:=xlDescending
S3.Cells(a, "D").Value = S3.Cells(a, "B").Value
S3.Cells(a, "E").Value = S3.Cells(a, "A").Value
S3.Cells(a, "F") = 1 + S3.Cells(a, "F")
End If
If WF.CountIf(S3.Range("B2:B" & a), S3.Cells(a, "B")) = 1 Then urun = urun + 1
Next
If Ürün_Sayısı * i > Application.Sum(S3.Range("F2:F" & s3r)) Then
S3.Range("D2:D" & s3r) = ""
c = c + 1: urun = 0: GoTo 10
End If
    son = S2.Cells.Find("*", SearchOrder:=xlByRows, searchdirection:=xlPrevious).Row
    S2.Cells(son + 3, 2) = "TOPLAM ÇEŞİT SAYISI"
    S2.Cells(son + 4, 2) = "YERLEŞTİRİLEN ÇEŞİT SAYISI"
    S2.Cells(son + 5, 2) = "TOPLAM"
    S2.Cells(son + 3, 5) = urun
    S2.Cells(son + 4, 5) = Application.Sum(S3.Range("F2:F" & s3r))
    S2.Cells(son + 5, 5) = TPL
  S2.Range("B" & son + 3 & ":D" & son + 3 & "," & "B" & son + 4 & ":D" & son + 4 & "," & "B" & son + 5 & ":D" & son + 5).Merge
    S2.Range("B" & son + 3 & ":E" & son + 5).Font.Bold = True
    S2.Range("B" & son + 3 & ":E" & son + 5).Borders.LineStyle = 1
End Sub

çok teşekkür ederim. Ellerinize sağlık.

Sadece çeşidi düzgün saymıyor onu da halledebilir miyiz hocam. Dmr 7 den wolwerine silip denedim. Yerine qauke atadı. Fakat quake zaten başka birinde vardı. 49 çeşit yerleşti demesi gerekirken 50 yazdı. ben yınelenenlerı kaldır dıyıp de saydım

Yerleştirme Ölçütlerinin Revize Edilmesi

DMR 7

alicimri

DMR 7

DMR 7

DMR 7

Korhan Ayhan

Administrator

DMR 7

DMR 7

DMR 7

DMR 7

DMR 7

Korhan Ayhan

Administrator

DMR 7

DMR 7

DMR 7

DMR 7

DMR 7

DMR 7

PLİNT

DMR 7