• DİKKAT

    DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
    Altın Üyelik Hakkında Bilgi

KOMBİNASYON

G

GAZOZ_55

Katılım
25 Ağustos 2018
Mesajlar
64
Excel Vers. ve Dili
Excel 2016, Türkçe.
Sonuç sütununda yer alan sayıların birbiriyle 2'li, 3'lü ve 4'lü kombinasyonlarını yapmak istiyorum. Bunu VBA ile nasıl yaparız?
 

Ekli dosyalar

Merhaba

Forumda kombinasyon olarak arama yapınız.

19 sayısının 4 lü kombinasyonu listeleme

Mrblar iş yeri için 19 farklı sayının excelde 4 lü kombinasyonunu alt alta nasıl listelerim bir projeyle yardımcı olursanız sevinirim. örn: 1234 1235 1236 1237 2357 4852 gibi ,şimdiden teşekkürler
www.excel.web.tr www.excel.web.tr

Kombinasyon sonucunu sayfalara yazdırabilirmiyiz

Selam Excelde kombinasyon sonucunu sayfalara yazdırabilirmiyiz örneğin 20 ismin 3 erli kombinasyonu 1140 adet oluyor VBA kodlarıyla veya başka bir yöntemle bu 1140 adet 3 erli ismi sayfaya/sayfalara yazdırabilirmiyiz
www.excel.web.tr www.excel.web.tr

.
 
Çok teşekkür ederim attığınız dosya için. Kombinasyonu kendiyle kombine olmayacak şekilde yapabilir miyiz?
 
Yaparız ama şu an çıkmam lazım.
Müsait olunca ekleyebiliriz.

Selamlar...
 
GAZOZ_55' Alıntı:
Çok teşekkür ederim attığınız dosya için. Kombinasyonu kendiyle kombine olmayacak şekilde yapabilir miyiz?
Genişletmek için tıkla ...

Merhaba

Yukardaki talebinizi biraz açabilirmisiniz.
Talebiniz birden çok yoruma müsait görünüyor.

Net olarak istediğiniz nasıl bir sonuç olsun.

Selamlar...
 
Hocam mesela 10,20,30,40,50 olan bir data serisinde, ekte yer alan resimdeki gibi (10,20), (10,30), (10,40), (10,50) olacak. Yani seride (10,10) yok. Data serisindeki bir data kendiyle eşleşmeyecek.
 

Ekli dosyalar

  • Screenshot_20200927-225311_Excel.jpg
    Screenshot_20200927-225311_Excel.jpg
    139.4 KB · Görüntüleme: 1
GAZOZ_55' Alıntı:
Hocam mesela 10,20,30,40,50 olan bir data serisinde, ekte yer alan resimdeki gibi (10,20), (10,30), (10,40), (10,50) olacak. Yani seride (10,10) yok. Data serisindeki bir data kendiyle eşleşmeyecek.
Genişletmek için tıkla ...

Merhaba

Son taleplerinizi içeren dosya Ek 'tedir.

Selamlar...
 

Ekli dosyalar

Merhaba

Bir yukardaki #10 nolu mesajımda eklediğim dosyada bazı hatalar farkettim.
Dosyanın düzeltilmiş son hali Ek 'tedir.
Yukardaki dosyayı indiren arkadaşlar bu son eklediğim dosyayı kullansınlar.

Selamlar...
 

Ekli dosyalar

Çok teşekkür ederim Ömer bey. Emeğinize sağlık.
 
kulomer46' Alıntı:
Merhaba

Bir yukardaki #10 nolu mesajımda eklediğim dosyada bazı hatalar farkettim.
Dosyanın düzeltilmiş son hali Ek 'tedir.
Yukardaki dosyayı indiren arkadaşlar bu son eklediğim dosyayı kullansınlar.

Selamlar...
Genişletmek için tıkla ...
selamlar acaba vba kodunu paylaşma şansınız var mı?
 
eralpolat' Alıntı:
selamlar acaba vba kodunu paylaşma şansınız var mı?
Genişletmek için tıkla ...

Merhaba

Vba Kodu, Ekran Görüntüsü ve İlgili dosya Ek 'lenmiştir.

Selamlar...

Ekran Görüntüsü
231660


İlgili Kod
Kod: 
Sub Kombinasyon_Aktar()
'28.09.2020   11:30

zaman = Timer
Cells(6, 5) = ""
Cells(7, 5) = ""

Cells.Interior.Color = xlNone
Range("F1:P" & ActiveSheet.Rows.Count).ClearContents

satırsayısı = ActiveSheet.Rows.Count

    Range("F1:G1").Merge
    Range("I1:K1").Merge
    Range("M1:P1").Merge
    Range("E7:E9").Merge
    Range("E7:E9").WrapText = True
    Range("E7:E9").Font.Size = 12

Cells(1, 6) = "2 'li Kombinasyon"
Cells(1, 9) = "3 'lü Kombinasyon"
Cells(1, 13) = "4 'lü Kombinasyon"


Range("F1").Select

DoEvents

timer1 = Timer
Do While Timer - timer1 < 0.3
Loop

Application.ScreenUpdating = False

DoEvents
sona = Cells(Rows.Count, 1).End(3).Row
Cells(6, 5) = "Eleman Sayısı :  " & sona - 1
Cells(6, 5).Font.Bold = True

Cells(1, 1).Interior.Color = RGB(255, 192, 0)
Range(Cells(2, 1), Cells(sona, 1)).Interior.Color = RGB(255, 230, 153)

ReDim dizi(sona)

For i = 1 To sona
   
    dizi(i) = Cells(i, 1)

Next

'Cells(1, 6) = "2 'li Kombinasyon"
Cells(7, 5) = "2 'li Kombinasyon Üzerinde Çalışıyorum"
s2 = s2 + 1

For i = 2 To sona
    For j = i + 1 To sona
       
            If s2 > satırsayısı Then
           
                Application.ScreenUpdating = True
                Cells(7, 5) = "2 'li Kombinasyon Çözümü" & Chr(10) & "Toplam Satır Sayısını Aştı." & Chr(10) & "Geçen Süre : " & Int(Timer - zaman) + 1 & "  Sn."
                Cells(1, 6) = "2 'li Kombinasyon" & Chr(10) & " Şu ana Kadar " & s2 - 1 & " Adet"
                Cells(1, 6).Interior.Color = RGB(146, 208, 80)
               
                Range(Cells(2, 13), Cells(satırsayısı, 16)).Interior.Color = RGB(255, 230, 153)
                MsgBox "Çözüm Toplam Satır Sayısını  (" & ActiveSheet.Rows.Count & ") Aştı." & Chr(10) _
                & Chr(10) & "Listeleme Sonlandırıldı" & Chr(10) & Chr(10) _
                & "İşlem Süresi :   " & Int(Timer - zaman) + 1 & "  Sn."
                Exit Sub
           
            End If
   
            s2 = s2 + 1
            Cells(s2, 6) = dizi(i)
            Cells(s2, 7) = dizi(j)
         
    Next
Next
Cells(1, 6) = "2 'li Kombinasyon" & Chr(10) & s2 - 1 & " Adet"
Cells(7, 5) = "3 'lü Kombinasyon Üzerinde Çalışıyorum"

Cells(1, 6).Interior.Color = RGB(255, 192, 0)
Range(Cells(2, 6), Cells(s2, 7)).Interior.Color = RGB(255, 230, 153)


Application.ScreenUpdating = True

DoEvents
timer1 = Timer
Do While Timer - timer1 < 0.1
Loop
DoEvents

Application.ScreenUpdating = False

'Cells(1, 9) = "3 'lü Kombinasyon"
'Cells(7, 5) = "3 'lü Kombinasyon Üzerinde Çalışıyorum"
s3 = s3 + 1

For i = 2 To sona
    For j = i + 1 To sona
        For p = j + 1 To sona
       
                If s3 > satırsayısı Then
               
                    Application.ScreenUpdating = True
                    Cells(7, 5) = "3 'lü Kombinasyon Çözümü" & Chr(10) & "Toplam Satır Sayısını Aştı." & Chr(10) & "Geçen Süre : " & Int(Timer - zaman) + 1 & "  Sn."
                    Cells(1, 9) = "3 'lü Kombinasyon" & Chr(10) & " Şu ana Kadar " & s3 - 1 & " Adet"
                    Cells(1, 9).Interior.Color = RGB(146, 208, 80)
                   
                    Range(Cells(2, 13), Cells(satırsayısı, 16)).Interior.Color = RGB(255, 230, 153)
                    MsgBox "Çözüm Toplam Satır Sayısını  (" & ActiveSheet.Rows.Count & ") Aştı." & Chr(10) _
                    & Chr(10) & "Listeleme Sonlandırıldı" & Chr(10) & Chr(10) _
                    & "İşlem Süresi :   " & Int(Timer - zaman) + 1 & "  Sn."
                    Exit Sub
               
                End If
   
                s3 = s3 + 1
                Cells(s3, 9) = dizi(i)
                Cells(s3, 10) = dizi(j)
                Cells(s3, 11) = dizi(p)
       
        Next
    Next
Next
Cells(1, 9) = "3 'lü Kombinasyon" & Chr(10) & s3 - 1 & " Adet"
Cells(7, 5) = "4 'lü Kombinasyon Üzerinde Çalışıyorum"

Cells(1, 9).Interior.Color = RGB(255, 192, 0)
Range(Cells(2, 9), Cells(s3, 11)).Interior.Color = RGB(255, 230, 153)


Application.ScreenUpdating = True

DoEvents

timer1 = Timer
Do While Timer - timer1 < 0.1
Loop

DoEvents

Application.ScreenUpdating = False

'Cells(1, 13) = "4 'lü Kombinasyon"

s4 = s4 + 1

For i = 2 To sona
    For j = i + 1 To sona
        For p = j + 1 To sona
            For d = p + 1 To sona
           
                    If s4 >= satırsayısı Then
                   
                        Application.ScreenUpdating = True
                        Cells(7, 5) = "4 'lü Kombinasyon Çözümü" & Chr(10) & "Toplam Satır Sayısını Aştı." & Chr(10) & "Geçen Süre : " & Int(Timer - zaman) + 1 & "  Sn."
                        Cells(1, 13) = "4 'lü Kombinasyon" & Chr(10) & " Şu ana Kadar " & s4 - 1 & " Adet"
                        Cells(1, 13).Interior.Color = RGB(146, 208, 80)
                                           
                        Range(Cells(2, 13), Cells(satırsayısı, 16)).Interior.Color = RGB(255, 230, 153)
                        MsgBox "Çözüm Toplam Satır Sayısını  (" & ActiveSheet.Rows.Count & ") Aştı." & Chr(10) _
                        & Chr(10) & "Listeleme Sonlandırıldı" & Chr(10) & Chr(10) _
                        & "İşlem Süresi :   " & Int(Timer - zaman) + 1 & "  Sn."
                        Exit Sub
                   
                    End If
           
                    s4 = s4 + 1
                    Cells(s4, 13) = dizi(i)
                    Cells(s4, 14) = dizi(j)
                    Cells(s4, 15) = dizi(p)
                    Cells(s4, 16) = dizi(d)
           
            Next
        Next
    Next
Next
Cells(1, 13) = "4 'lü Kombinasyon" & Chr(10) & s4 - 1 & " Adet"

Cells(1, 13).Interior.Color = RGB(255, 192, 0)
Range(Cells(2, 13), Cells(s4, 16)).Interior.Color = RGB(255, 230, 153)

Rows("1:1").RowHeight = 49

Cells(7, 5) = "İşlem Tamam" & Chr(10) & "Geçen Süre : " & Int(Timer - zaman) + 1 & "  Sn."
Application.ScreenUpdating = True

MsgBox "İşlem Tamam" & Chr(10) & Chr(10) & "İşlem Süresi :   " & Int(Timer - zaman) + 1 & "  Sn.", , "İŞLEM"

End Sub

DOSYA_KOMBINASYON__28.09.2020__yenisi.xlsm dosyasını indir - download

DOSYA_KOMBINASYON__28.09.2020__yenisi.xlsm dosyasını indir, download. Dosya.tc .Dosya Upload. Dosya Paylaş. Dosya Yükle
s6.dosya.tc s6.dosya.tc
 

Ekli dosyalar

Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst