KOMBİNASYON

[vartolu]

iyi akşamlar resimde gördüğünüz tabloda 1'den 10'a kadar sayılar var bu sayıları 1'den 10' a kadar bir arada olacak şekilde kombinasyon yapmak istiyorum örnek olarak :
A1,B1,E1,F1,G1 SUTUNLARI 1'den 10'a kadar tamamlıyor.
veya
B1,D1,E1,H1 SUTUNLARIDA TAMAMLIYOR.

yani 5 kombinasyonda çıkabiliyor 4 kombinasyonda çıkabiliyor benim istediğim bir formül ya da macroyla bu çıkan sonuçların direk olarak A1,B1,E1,F1,G1 olarak yazması benim elimdede çok kalabalık bir dosya var tek tek ugraşıp yapmam aylar sürer yardımcı olursanız çok sevinirim.

 

[kulomer46]

Merhaba

Resim eklerseniz yada bir şekilde dosya paylaşırsanız konu ilgi çekici yardımcı olalım.

Selamlar...

 

[vartolu]

Merhaba

Resim eklerseniz yada bir şekilde dosya paylaşırsanız konu ilgi çekici yardımcı olalım.

Selamlar...

Resim var zaten gözükmüyor mu ?

https://i.hizliresim.com/Rgdkaj.png

 

[kulomer46]

Resim var zaten gözükmüyor mu ?

Merhaba

İşyeri internetim resim bağlantınızı açmama izin vermiyor. Resmi göremiyorum.
Fırsat bulabilirsem akşam evde bakabilirim ancak.

Selamlar...

 

[vartolu]

Merhaba

İşyeri internetim resim bağlantınızı açmama izin vermiyor. Resmi göremiyorum.
Fırsat bulabilirsem akşam evde bakabilirim ancak.

Selamlar...

Resim var zaten gözükmüyor mu ?

https://i.hizliresim.com/Rgdkaj.png

5D612941 2D84 4433 9C2A A1662F31FFDA

Resim 5D612941 2D84 4433 9C2A A1662F31FFDA kaydedildi Resim Yükle - Hızlı Resim

imgyukle.com

https://i.imgyukle.com/2020/01/16/V1YD4s.png

Resmim.NET

Resmi görüntülemek veya indirmek için tıklayın.

resmim.net

Resimag - 4d08073add4

Bunlari deneyin acmazsa whatsapptan atabilirim

 

[kulomer46]

Merhaba

Eklediğiniz resmi gördüm, talebinizi anladım.
Çözüm üzerinde çalışıyorum.
Çözüm bulduğumda buraya eklerim İnşallah.

Selamlar..

 

[vartolu]

Merhaba

Eklediğiniz resmi gördüm, talebinizi anladım.
Çözüm üzerinde çalışıyorum.
Çözüm bulduğumda buraya eklerim İnşallah.

Selamlar..

Hocam valla o kadar büyük bir iyilik yapmış olursunuz ki çok önemli benim için iyi çalışmalar.

 

[ÖmerBey]

Merhaba,
Soruda benim anlamadığım bir durum var: Oluşabilecek bütün kombinasyonları mı istiyorsunuz, sadece bir tanesi yeterli mi? Bir tane yeterli ise hangi bir tanesi olacak?

 

[vartolu]

Merhaba,
Soruda benim anlamadığım bir durum var: Oluşabilecek bütün kombinasyonları mı istiyorsunuz, sadece bir tanesi yeterli mi? Bir tane yeterli ise hangi bir tanesi olacak?

Olusabilecek tüm kombinasyonlar hocam biraz karışık ama bana gerekli olan bu

 

[vartolu]

Merhaba

Eklediğiniz resmi gördüm, talebinizi anladım.
Çözüm üzerinde çalışıyorum.
Çözüm bulduğumda buraya eklerim İnşallah.

Selamlar..

Varmı hocam bir gelişme bakabildiniz mi ?

 

[ÖmerBey]

Merhaba,
Ekteki dosyayı deneyiniz...

 

[vartolu]

Merhaba,
Ekteki dosyayı deneyiniz...

Çok teşekkür ederim çok sağolun haftalardır bunu arıyordum fakat bir sorunum daha var pek anlamadığım için macronun nerelerini değiştiricem
gönderdiğiniz ekte sadece A hücresinden H hücresine kadar kombine yapabiliyoruz benim listem çok daha kalabalık
A hücresinden LH ye kadar
uzunluğu ise 200 satır

 

[ÖmerBey]

Gönderdiğiniz örnek A-H aralığı kadardı ben de kodu ona göre yazdım. Belirttiğiniz aralıkta kodun hesaplayamayacağı kadar kombinasyon oluşacaktır. Yine de denemek istiyorsanız kodda 8 yazan yerler sütun, 10 yazan yerler satır sayısı; değiştirip deneyiniz. (Bilgisayarınızın kilitleneceğini göz önüne alınız)
Bir de resim yerine asıl dosyanızın benzeri bir örnek dosya paylaşırsanız daha doğru yardım alırsınız.

 

[vartolu]

Gönderdiğiniz örnek A-H aralığı kadardı ben de kodu ona göre yazdım. Belirttiğiniz aralıkta kodun hesaplayamayacağı kadar kombinasyon oluşacaktır. Yine de denemek istiyorsanız kodda 8 yazan yerler sütun, 10 yazan yerler satır sayısı; değiştirip deneyiniz. (Bilgisayarınızın kilitleneceğini göz önüne alınız)
Bir de resim yerine asıl dosyanızın benzeri bir örnek dosya paylaşırsanız daha doğru yardım alırsınız.

Tamamdir cok sağolun tekrar teşekkürler

 

[vartolu]

Gönderdiğiniz örnek A-H aralığı kadardı ben de kodu ona göre yazdım. Belirttiğiniz aralıkta kodun hesaplayamayacağı kadar kombinasyon oluşacaktır. Yine de denemek istiyorsanız kodda 8 yazan yerler sütun, 10 yazan yerler satır sayısı; değiştirip deneyiniz. (Bilgisayarınızın kilitleneceğini göz önüne alınız)
Bir de resim yerine asıl dosyanızın benzeri bir örnek dosya paylaşırsanız daha doğru yardım alırsınız.

https://www.dosya.tc/server25/w0rmk1/AA.xlsx.html
RİCA ETSEM BUNA GÖRE DÜZENLERMİSİNİZ KODU BEN YAPAMADIM.

 

[vartolu]

https://www.dosya.tc/server25/db3nbj/AA.xlsx.html

Merhabalar vermiş olduğum dosyadaki tabloda her sutunda 1 den 97 e kadar sayılar yazmakta , ve bu sutunlar birbirlerinden farklı bazısında 20 21 22 gibi sayılar yok bazılarında ise 35 40 50 vs vs gibi sayılar yok ben bunların kombinelerini oluşturmak ve bu kombinelerin en az sutunlu olanlarını bulmak istiyorum yani örnek verecek olursak
A sutununda 25 26 27 28 yok b sutununda da 33 34 35 36 37 38 39 yok c sutunundada 1 7 8 9 10 11 yoK.
olanı olmayan ile tamamlayıp en az sutunlu kombineleri bulmak istiyorum yardımcı olursanız sevinirim.

NOT: ANLAMAYANLAR İÇİN DOSYAYI AÇTIĞINIZDA SEKMELER BÖLÜMÜNDE İSTENEN SONUÇ A TIKLASIN ORADA DAHA DETAYLI ANLATTIM.

 

[Necdet]

Merhaba,

Soru başlığınızı sorunuzu özetler şeklinde değiştiriniz.
Kimse forumda "Yardım Lütfen" diye arama yapmaz.

 

[vartolu]

Merhaba,

Soru başlığınızı sorunuzu özetler şeklinde değiştiriniz.
Kimse forumda "Yardım Lütfen" diye arama yapmaz.

degisrirmek icin secenek yok yeniden açtım konuyu

 

[PLİNT]

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

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

 

[vartolu]

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

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

Çok sağolun ama bana 1 den 97 ye kadar tam tamamlaması lazım o yüzden 2 sutunla tamamlayan işime yaramıyor kodlarda nerelerde değişiklik yapıcam ? bekleme süresi hiç önemli değil isterse 2 saat bekleyeyim ama yeterki çıksın.