Soru Eksiksiz Kümeleri Bulma

[konas06]

Çokça sayı kümeleri bulunan bir işlemde,
Belirtilen bir sayı aralığını en az kümede eksiksiz tamamlamak için nasıl bir formül yada kod uygulanabilir.

 

[ÖmerFaruk]

Soruyu biraz daha açar mısın?

 

[konas06]

1 den 135 e kadar olan sütunlarda 1-90 kadar karışık sayılar bulunuyor.
Bu bilgilerden,
Sütun aralığını ve sayı aralığını dinamik yapıp, bu sayı aralığını eksiksiz en az sütun ile nasıl tamamlayabiliriz.
Tamamlanamadığında "yoktur" gibi bir ifade kullanılabilir.

 

[ÖmerFaruk]

Anladığım doğru mudur?
Kümeler sayfasında C-EG sütunlarında, küme nosu 2.satırda yazan ve 3-17. satırlar arası elemanları verilmiş sabit kümelerimiz var.

Sonuç sayfasında
Küme nosu verilen aralık dahilinde olan kümelerden (örnekteki 1-20 arası küme noları)
Öyle bir küme listesi seç ki sayı numara aralığındaki tüm elemanlar bu küme listesinde bulunsun.

Eğer numara aralığını kapsayan tüm numaralar varsa kümeleri listele,
Yoksa...listeleme ve YOKTUR yaz

 

[konas06]

Doğrudur.

 

[ÖmerFaruk]

Bir hayli kazık konu. =)
Umarım bir çözen olur. Ben de merak ettim nasıl bir algoritma kurulacak.
Verilen aralık dahilindeki Rastgele aralık genişliğine başlı olarak bir ya da birden fazla kümenin birleşim kümesinin sayı aralığındaki tüm sayıları içersin.
Yazarken kolay gibi, çözerken kazık.

 

[konas06]

Çözümü çok önemli değil hocam. Sizi heyecanlandırabilmek bile keyifli.

 

[veyselemre]

Sub kümeBul()
    
    Dim s1 As Worksheet, s2 As Worksheet
    Dim aramaBas As Integer, aramaSon As Integer
    Dim arananSayiBas As Integer, arananSayiSon As Integer
    Dim dicKalanKumeler As Object, dicKalanRakamlar As Object, dicAranacakKumeler As Object
    Dim i As Integer, ii As Integer, mn As Integer, sutun As Integer, say As Integer, mx As Integer, sira As Integer, s As Integer
    Dim kume As String, bak As String, mnBak As String, bulunan As String, mxBulunan As String, kys As String
    Dim kysKalanKumeler, itmsKalanKumeler, kysKalanRakamlar, kysAranacakKumeler, itmsAranacakKumeler, al
    
    Set s1 = Sheets("KÜMELER")
    Set s2 = Sheets("SONUÇ")

    aramaBas = s2.Range("C2")
    aramaSon = s2.Range("D2")
    arananSayiBas = s2.Range("C3")
    arananSayiSon = s2.Range("D3")

    Set dicKalanKumeler = CreateObject("Scripting.Dictionary")
    Set dicKalanRakamlar = CreateObject("Scripting.Dictionary")
    Set dicAranacakKumeler = CreateObject("Scripting.Dictionary")

    For i = aramaBas To aramaSon
        kume = ""
        For ii = 2 To 17
            kume = kume & s1.Cells(ii, i + 2).Value & ","
        Next ii
        dicKalanKumeler.Add Trim(i), kume
    Next i

    For i = arananSayiBas To arananSayiSon
        dicKalanRakamlar.Add Trim(i), Null
    Next i

    s2.Range("C6:EG6").ClearContents
    s2.Range("C7:EG100").Clear

    bak = ""
    sutun = 3

    Do While dicKalanRakamlar.Count > 0

        mn = 9999#

        kysKalanKumeler = dicKalanKumeler.keys
        itmsKalanKumeler = dicKalanKumeler.items
        kysKalanRakamlar = dicKalanRakamlar.keys

        For i = 0 To UBound(kysKalanRakamlar)
            bak = "," & kysKalanRakamlar(i) & ","
            say = 0

            For ii = 0 To UBound(itmsKalanKumeler)
                If InStr(itmsKalanKumeler(ii), bak) Then say = say + 1
            Next ii

            If say > 0 And say < mn Then
                mn = say
                mnBak = bak
            End If

        Next i

        dicAranacakKumeler.RemoveAll
        For ii = 0 To UBound(itmsKalanKumeler)
            If InStr(itmsKalanKumeler(ii), mnBak) Then
                dicAranacakKumeler.Add kysKalanKumeler(ii), itmsKalanKumeler(ii)
            End If
        Next ii

        kysAranacakKumeler = dicAranacakKumeler.keys
        itmsAranacakKumeler = dicAranacakKumeler.items

        mx = 0
        sira = -1

        For i = 0 To UBound(itmsAranacakKumeler)
            bak = itmsAranacakKumeler(i)
            say = 0
            bulunan = ","
            For ii = 0 To UBound(kysKalanRakamlar)
                If InStr(bak, "," & kysKalanRakamlar(ii) & ",") Then
                    say = say + 1
                    bulunan = bulunan & kysKalanRakamlar(ii) & ","
                End If
            Next ii
            If say > mx Then
                mx = say
                sira = i
                mxBulunan = bulunan
            End If
        Next i

        If sira > -1 Then
            al = Split(dicAranacakKumeler(kysAranacakKumeler(sira)), ",")
            dicAranacakKumeler.Remove kysAranacakKumeler(sira)
            dicKalanKumeler.Remove kysAranacakKumeler(sira)

            s2.Cells(6, sutun).Value = al(0)
            For i = 1 To UBound(al) - 1
                s2.Cells(i + 6, sutun).Value = al(i)
                If InStr(mxBulunan, "," & al(i) & ",") And dicKalanRakamlar.exists(Trim(al(i))) Then
                    's2.Cells(i + 6, sutun).Value = al(i)
                    s2.Cells(i + 6, sutun).Font.Color = vbRed
                    dicKalanRakamlar.Remove Trim(al(i))
                End If
            Next i
            sutun = sutun + 1
        End If

        s = s + 1
        If s = 100 Then Exit Do

    Loop

    If dicKalanRakamlar.Count > 0 Then
        kys = Join(dicKalanRakamlar.keys, ",")
        MsgBox "Tüm Rakamlar Bulunamadı" & vbCr & "Bulunamayan Rakamlar : " & kys
    End If
End Sub

 

[ÖmerFaruk]

@veyselemre süper olmuş. Ve oldukça da hızlı.

 

[konas06]

Çok güzel ellerinize, emeğinize sağlık.
Kümeler tamam. Kırmızı renklendirme olmayan hücreler var, çok önemli değil.
Bu haliyle de işimi görür.

 

[veyselemre]

Kümeler tamam. Kırmızı renklendirme olmayan hücreler var, çok önemli değil.

Derken ?