KOMBİNASYON

vartolu · 19 Ocak 2020

Merhaba
Ek dosyayı denermisiniz?
https://www.dosyaupload.com/70km
Dosyada 320 sütundan ikili kombinasyonla, en fazla birbirini tamamlayan iki sütunu seçecek.
Üç, dört sütun karşılaştırması yapılıp daha fazla tamamlayan bulunabilir ama dosyada göreceğiniz gibi ikilide bile uzun zaman alıyor

Kod:

Private Sub CommandButton1_Click()
Dim adr As String, adr2 As String, adr3 As String, dc, dic, rf(), rm(), t As Long, j As Range
Dim a As Long, b As Long, c As Long, s1 As Worksheet, s2 As Worksheet, s1x As Long
Dim kac As Long, kac2 As Long, tpl As Long
Set s1 = Sheets(1)
Set s2 = Sheets(3)
s1x = s1.Cells.Find("*", searchorder:=xlByRows, searchdirection:=xlPrevious).Row
For a = 1 To 319
Cells(1, a).Select
     Set dc = CreateObject("Scripting.Dictionary")
rf = s1.Range(Cells(2, a), Cells(s1x, a)).Value
     For b = LBound(rf) To UBound(rf)
     If Trim(rf(b, 1)) <> "" And Not dc.exists(Trim(rf(b, 1))) Then dc.Add Trim(rf(b, 1)), ""
     Next
For c = a + 1 To 320
      Set dic = CreateObject("Scripting.Dictionary")
           rm = s1.Range(Cells(2, c), Cells(s1x, c)).Value
               For b = LBound(rm) To UBound(rm)
                    If Trim(rm(b, 1)) <> "" And Not dc.exists(Trim(rm(b, 1))) Then dic.Add Trim(rm(b, 1)), ""
                    Next
            If adr = "" Then
            adr = Columns(c).Address
            kac = dic.Count
            End If
     If kac < dic.Count Then
      adr = Columns(c).Address
            kac = dic.Count
            End If
Set dic = Nothing
           Next c
         
If adr2 = "" Then
adr2 = Columns(a).Address
            kac2 = dc.Count
            tpl = kac + kac2
            End If

If kac2 < dc.Count Then
adr2 = Columns(a).Address
            kac2 = dc.Count
            End If

If tpl < kac + kac2 Then
tpl = kac + kac2
adr3 = adr2 & "/" & adr
End If
kac = 0
kac = 0
Set dc = Nothing
Next
s2.Activate
s = 1
s2.[A:B].ClearContents
s2.[A1] = Split(Split(adr3, "/")(0), ":$")(1)
s2.[B1] = Split(Split(adr3, "/")(1), ":$")(1)
For t = 1 To 2
For Each j In s1.Range(s2.Cells(1, t) & 2 & ":" & s2.Cells(1, t) & s1x)
If j.Value <> "" Then
If WorksheetFunction.CountIf(s2.Range("A2:B" & s1x), j.Value) = 0 Then
s = s + 1
s2.Cells(s, t) = j.Value
End If: End If
Next:
s = 1
Next
End Sub

Hocam yazarmisiniz lütfen çok önemli gerçekten.

Korhan Ayhan · 19 Ocak 2020

Deneyiniz.

İşlem bende 5 saniye kadar sürdü.

Kod:

Option Explicit

Sub Kombinasyonlari_Listele()
    Dim S1 As Worksheet, S2 As Worksheet, Veri As Variant, Dizi As Object
    Dim X As Long, Y As Long, Z As Long, Harf As String, Say As Long
    Dim Satir As Long, Kombinasyon As String, Maksimum As Double, Zaman As Double
    
    Zaman = Timer
    
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    
    On Error Resume Next
    Application.DisplayAlerts = False
    Sheets("Kombinasyonlar").Delete
    Application.DisplayAlerts = True
    On Error GoTo 0
    
    Set S1 = Sheets("Sayfa1")
    Sheets.Add , Worksheets(Worksheets.Count)
    Set S2 = ActiveSheet
    S2.Name = "Kombinasyonlar"
    S2.Range("A1:B1") = Array("Kombinasyonlar", "Uzunluk")
    S2.Range("A1:B1").Font.Bold = True
    S2.Range("A1:B1").Font.ColorIndex = 3
    S2.Range("A:B").EntireColumn.AutoFit
    
    Set Dizi = CreateObject("Scripting.Dictionary")
    
    ReDim Liste(1 To 1048576, 1 To 2)
    
    Maksimum = WorksheetFunction.Max(S1.Cells)
    Satir = S1.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row

    For X = 1 To 320
        For Y = X To 320
            Harf = Replace(S1.Cells(1, Y).Address(0, 0), 1, "")
            Kombinasyon = Kombinasyon & "," & Harf
            
            Veri = S1.Cells(1, Y).Resize(Satir).Value
            
            For Z = 1 To UBound(Veri)
                If Veri(Z, 1) <> "" Then
                    If Not Dizi.Exists(Veri(Z, 1)) Then
                        Dizi.Add Veri(Z, 1), Nothing
                    End If
                End If
            Next
            
            If Dizi.Count = Maksimum Then
                Say = Say + 1
                Liste(Say, 1) = Mid(Kombinasyon, 2, Len(Kombinasyon) - 1)
                Liste(Say, 2) = Len(Liste(Say, 1))
                Kombinasyon = ""
                Dizi.RemoveAll
            End If
        Next
    Next
    
    S2.Range("A2").Resize(Say, 2) = Liste
    S2.Range("A1:B" & S2.Rows.Count).RemoveDuplicates Columns:=1, Header:=xlYes
    S2.Range("A2:B" & S2.Rows.Count).Sort S2.Range("B2"), xlAscending
    
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
    
    MsgBox "İşleminiz tamamlanmıştır." & Chr(10) & _
           "İşlem süresi ; " & Format(Timer - Zaman, "0.00") & " Saniye", vbInformation
End Sub

PLİNT · 20 Ocak 2020

Merhaba
Korhan hocam cevap vermiş ama hazırlamışken ekledim, alternetif olarak değerledirirsiniz
https://www.dosyaupload.com/foSm

Korhan Ayhan · 20 Ocak 2020

İşlem süresini 5 saniyeye kadar düşürdüm. Üstteki mesajımdaki kodu revize ettim. Denersiniz.

vartolu · 20 Ocak 2020

PLİNT' Alıntı:
Merhaba
Korhan hocam cevap vermiş ama hazırlamışken ekledim, alternetif olarak değerledirirsiniz
https://www.dosyaupload.com/foSm

Hocam korhan hocanin verdiği ikili kombinasyon olarak çıkıyor sizin en son verdiginiz dosyalardada 2 li ve 3 lü kombinasyon ayarlamissiniz ama islemi gerceklestirdim zaman sonuclari yazmiyor çünkü 1den 97 ye kadar tamamladığı kombinasyon sayısını bilmiyorum bilsem size 5 li 6 lı 7 lı vs çıkıyor derim ancak bilmedigim için soyleyemiyorum benim istediğim sadece kombinasyon sayisini ve sütunlarını bilmek

vartolu · 20 Ocak 2020

Korhan Ayhan' Alıntı:
İşlem süresini 5 saniyeye kadar düşürdüm. Üstteki mesajımdaki kodu revize ettim. Denersiniz.

yok hocam sizin verdiğiniz kodları denedim benim istediğim amaca uygun değil siz sadece kombinasyonları çıkarmışssınız
benim istediğim 1 den 320 ye kadar sutun var
o sutunlarda 1 den 97 ye kadar sayılar var bazılarında 1,2,3 yok bazısında 7,10,15 veya 50,60,70,80,81,82 vs vs yok
istenen tam olarak A SUTUNUNDA örneğin 1 DEN 40 a kadar sayı var b sutunuda 40 dan 70 e kadar c sutununda 70 den 97 ye kadar sayı var bu durumda ne oluyor 3 harfli bir kombinasyon çıkıyor (A,B,C) Ama benim tablomda kaç kombinasyonlu çıktığını bilmiyorum çok fazla sutun olduğu için elle yapmamda mümkün değil yardımlarınız için şimdiden teşekkürler.

PLİNT · 20 Ocak 2020

Merhaba
Yapılması gereken ilk önce sütunlarda en az bulunan veriden (mesela "9" 320 sütundan 12 sinde; "4" 14 tanesinde bulunuyor) en çok olana doğru tesbit edilmesi ve kombinasyonun bu az olan veriyi barındıran sütunlardan başlaması, vakit bulunca buna göre bir örnek yapmaya çalışırım

vartolu · 20 Ocak 2020

PLİNT' Alıntı:
Merhaba
Yapılması gereken ilk önce sütunlarda en az bulunan veriden (mesela "9" 320 sütundan 12 sinde; "4" 14 tanesinde bulunuyor) en çok olana doğru tesbit edilmesi ve kombinasyonun bu az olan veriyi barındıran sütunlardan başlaması, vakit bulunca buna göre bir örnek yapmaya çalışırım

Hocam ilgi ve alakanız için çok teşşekür ederim uğraştırıyorum sizi ama benim işim çok önemli ve aciliyeti var açıkça konuşayım işin ucunda para var evliyim 2 çocuğum var geçimimi sağlamaya çalışıyorum kendimce en yakın zamanda cevabınızı bekliyorum tekrar sağolun.

leguminosea · 20 Ocak 2020

https://www.dosyaupload.com/nNi3
istediğiniz işlemi fonksiyonlarla yaptım.
Dosya ekte. Umarım işinize yarar.

vartolu · 20 Ocak 2020

leguminosea' Alıntı:
https://www.dosyaupload.com/nNi3
istediğiniz işlemi fonksiyonlarla yaptım.
Dosya ekte. Umarım işinize yarar.

Hocam çok iyi düşünmüşsünüz ama şöyle bir şey var siz 28 adet kombinasyon çıkarmışsınız ben birbirini tamamlayarak yapmak istiyorum.
yani ben el ile göz gezdirdiğimde 18-19 kombinasyon çıkartabiliyorum benim amacım örneğin
A sutununda 1,2,3,4
B sutununda 3,4,5,6,7
C sutununda 6,7,8,9,10
D sutununda 8,9,10

sonuç olarak A,B,C de oluyor , A,B,D'de oluyor önemli olan en az sutunlu kombinasyonu bulmak.

bir başka örnek vereyim.

A sutununda 1,2,3,4,5,6,7
B sutununda 3,4,5,6,7,8,9,10
C sutununda 1
D sutununda 8,9,10

Burada mesela en az çıkan sonuç = A,B oluyor

ama ben fazla çıkartmak istesem A,B,C,D olur.

Umarım anlatabilmişimdir ilginiz için teşekkürler.

Korhan Ayhan · 20 Ocak 2020

İşin ucunda para var demişsiniz. Konunun parayla ilgisini merak ettim.

vartolu · 21 Ocak 2020

Korhan Ayhan' Alıntı:
İşin ucunda para var demişsiniz. Konunun parayla ilgisini merak ettim.

Benim kendi işimle alakalı.

PLİNT · 21 Ocak 2020

Merhaba
Yukarıdaki mesajımda belirttiğim duruma göre; sayılardan en az olanları barındıran sütunlarla, kalabalık olan sütunları öne alarak çıkan sonuç ekde, deneyin.
https://www.dosyaupload.com/bcUb

Kod:

Private Sub CommandButton1_Click()
Dim m As String, fg As Range, s As Long, s1 As Worksheet, s2 As Worksheet, s3 As Worksheet
Dim ararow As Long, j As Range, sr2 As Long, sc2 As Long, sr As Long, sc As Long, p As Long
Dim col As Long, u As Long, a As Long, b As Long, adet As Long, sutsay As Long, at As Long
Dim q As Long, qq As Long, y As Long, kl As Range, dc, sor
Set s1 = Sheets(1)
Set s2 = Sheets(3)
Set s3 = Sheets(4)
s2.Cells = ""
s3.Cells = ""
's2.Cells.ClearContents
's3.Cells.ClearContents
s = 1
sr = s1.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
sc = s1.Cells.Find("*", SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column
ararow = 1
For Each j In s1.Range("A2:LH" & sr)
If Trim(j) <> "" Then
s = s + 1
s2.Cells(j.Column + 1, s2.Cells(j.Column + 1, Columns.Count).End(xlToLeft).Column + 1) = j.Value
End If
Next
s2.Cells(2, 1) = "1"
s2.Cells(2, 1).AutoFill Destination:=s2.Range("A2:A" & sc + 1), Type:=xlFillSeries
s2.Columns("B:D").Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
sr2 = s2.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
sc2 = s2.Cells.Find("*", SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column
For p = 1 To sr - 1
s2.Cells(p + 1, 2) = WorksheetFunction.CountIf(s2.Range(s2.Cells(2, "E"), s2.Cells(sr2, sc2)), p)
s2.Cells(p + 1, 3) = p
Next

s2.Range(s2.Cells(2, 2), s2.Cells(sr, 3)).Sort Key1:=s2.Cells(2, "B"), Order1:=xlAscending
For b = 2 To sr
For a = 2 To sr2
col = s2.Cells(a, Columns.Count).End(xlToLeft).Column
If WorksheetFunction.CountIf(s2.Range(s2.Cells(a, 5), s2.Cells(a, col)), s2.Cells(b, 3).Value) <> 0 And s2.Cells(a, "D") = "" Then
s2.Cells(a, "D") = b - 1
End If
Next: Next
s2.Range(s2.Cells(2, 1), s2.Cells(sr2, sc2)).Sort Key1:=s2.Cells(2, "D"), Order1:=xlAscending
s2.[C:C] = ""
'----------------------------------------------
For u = 2 To Val(sr2 / 2) '<<----------------------------------
adet = WorksheetFunction.CountIf(s2.Range(s2.Cells(u, 4), s2.Cells(sr2, 4)), s2.Cells(u, 4).Value)
col = s2.Cells(u, Columns.Count).End(xlToLeft).Column
sutsay = WorksheetFunction.CountA(s2.Range(s2.Cells(u, 5), s2.Cells(u, col)))
If fg Is Nothing Then Set fg = s2.Range("C" & u & ":C" & u + adet - 1)
If at = 0 Or at < sutsay Then
fg = ""
at = sutsay
s2.Cells(u, 3) = at
End If
If u = u + adet - 1 Then
u = u + adet - 1
at = 0: adet = 0
Set fg = Nothing
End If
Next
10:
sr2 = s2.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
sc2 = s2.Cells.Find("*", SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column
s2.Range(s2.Cells(2, "A"), s2.Cells(sr2, sc2)).Sort Key1:=s2.Cells(2, "C"), Order1:=xlDescending
q = 0: qq = 0: gv = 0
Set dc = CreateObject("Scripting.Dictionary")
Set dic = CreateObject("Scripting.Dictionary")
For vv = 1 To sr - 1    '97 <--------------------
dic.Add vv, ""
Next
'---------------------------------------------------------------
For s = 1 To sr - 1   '97 '<<-----------------------------
m = s
Set ara = s2.Range(s2.Cells(1, 5), s2.Cells(3, sc2)).Find(m, , xlFormulas, xlWhole, xlByRows, xlNext, False, False)
If Not ara Is Nothing Then
If Not dc.exists(s2.Cells(ara.Row, 1).Value) Then dc.Add s2.Cells(ara.Row, 1).Value, ""
dic.Remove s
End If
Next
s2.[C:C] = ""
For Each kk In dic.keys
m = kk
With s2.Range(s2.Cells(4, 5), s2.Cells(sr2, sc2))
    Set ch = .Find(m, , xlFormulas, xlWhole, xlByRows, xlNext, False, False)
    If Not ch Is Nothing Then
f = ch.Address
        Do
s2.Cells(ch.Row, "C") = s2.Cells(ch.Row, "C") + 1

Set ch = .FindNext(ch)
If ch Is Nothing Then Exit Do
        Loop While Not ch Is Nothing And ch.Address <> f
    End If
End With
Next
s2.Range(s2.Cells(4, 1), s2.Cells(sr2, sc2)).Sort Key1:=s2.Cells(4, "C"), Order1:=xlDescending
Set dic = Nothing
dc.RemoveAll
For s = 1 To sr - 1   '97 '<<-----------------------------2
m = s
Set ara = s2.Range(s2.Cells(1, 5), s2.Cells(sr2, sc2)).Find(m, , xlFormulas, xlWhole, xlByRows, xlNext, False, False)
If Not ara Is Nothing Then
If Not dc.exists(s2.Cells(ara.Row, 1).Value) Then dc.Add s2.Cells(ara.Row, 1).Value, ""
End If
Next
col = s3.Cells(1, Columns.Count).End(xlToLeft).Column
If col <> 1 Then col = col + 2
For Each k In dc.keys
q = q + 1
s3.Cells(q, col) = k
Next k
s3.Range(s3.Cells(1, col), s3.Cells(dc.Count, col)).Sort Key1:=s3.Cells(1, col), Order1:=xlAscending
For Each kl In s3.Range(s3.Cells(1, col), s3.Cells(dc.Count, col))
s3.Cells(1, col + qq) = Replace(Columns(kl.Value).Address, "$", "")
If kl.Row <> 1 Then s3.Range(kl.Address) = ""
qq = qq + 1
Next
For y = col To col + qq - 1
qv = 2
For Each kl In s1.Range(s3.Cells(1, y).Value).SpecialCells(xlCellTypeConstants, 3)
s3.Cells(qv, y) = kl
qv = qv + 1
Next: Next
sr3 = s3.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
s3.Activate
For y = col + qq - 1 To col + 1 Step -1
For Each kl In s3.Range(s3.Cells(2, y), s3.Cells(sr3, y))
If kl <> "" Then
s3.Range(s3.Cells(2, col), s3.Cells(sr3, col + qq - 1)).Select
If WorksheetFunction.CountIf(s3.Range(s3.Cells(2, col), s3.Cells(sr3, col + qq - 1)), kl) > 1 Then
s3.Range(kl.Address) = ""
End If: End If
Next:
s3.Range(s3.Cells(2, y), s3.Cells(sr3, y)).Sort Key1:=s3.Cells(2, y), Order1:=xlAscending
If s3.Cells(Rows.Count, y).End(3).Row = 1 Then
s3.Columns(y).Delete Shift:=xlToLeft
qq = qq - 1
End If
Next
Set dc = Nothing
s3.Range(s3.Cells(2, col), s3.Cells(sr3, col + qq - 1)).Select
sor = MsgBox(qq & " Adet sütunla işlem bitti" & vbCrLf & "Evet i seçerek tekrarlayın", vbYesNo)
If sor = vbYes Then
ararow = ararow + 1
s2.Range(s2.Cells(ararow, 5), s2.Cells(ararow, sc2)) = ""
GoTo 10
End If

End Sub

leguminosea · 21 Ocak 2020

Hata indir

Hata

www.dosyaupload.com

Bu da aynı mantıkla fonksiyonlarla yapılmış versiyonu.
Mevcut verilerle benim bilgisayarımda dosyanın açılması birbuçuk dakika sürüyor.
Dosya ekte. Sanırım bu sefer oldu.

KOMBİNASYON

vartolu

Korhan Ayhan

Administrator

PLİNT

Korhan Ayhan

Administrator

vartolu

vartolu

PLİNT

vartolu

leguminosea

vartolu

Korhan Ayhan

Administrator

vartolu

PLİNT

leguminosea

Hata indir