• DİKKAT

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

Sayı dizisi seçmek.

R

rgulec50

Katılım
22 Kasım 2017
Mesajlar
44
Excel Vers. ve Dili
Excel 2016 - TR
Arkadaşlar başlık doğru oldumu emin değilim ama emin olun uzun süredir , excel formülleriyle basit makroyla çözmeye çalıştığım bir sorun bu... :confused:

Özetlemeye çalışırsam : bir sayı dizisinden başka bir sayı dizisini seçmeye çalışıyorum... örnekte detaylı anlattım.... konunun sıkı takipçisiyim sabah: 08.30 gece 01.00 :rolleyes::rolleyes::rolleyes::yardim:

yardımcı olan arkadaşlara şimdiden tşk ederim.
 
Son düzenleme:
arkadaşlar konu karmaşık değil biliyorum biraz anlatması zor...
 
Çözümü imkansızmıdır bunun beyler?Olumlu olumsuz bi'cevap bekliyorum açıkçası.
 
Beyler algoritmayı verdim, geriye sadece kodlamanın kaldığını düşünüyorum, yanılıyorsam söyleyin lütfen.
 
Bir şeyler kurguladım. Fakat bu aşamada tam sonuç vermiyor. Devamını yarın müsait bir zamanda tamamlamaya çalışırım.

Kod: 
Option Explicit

Sub Sayi_Dizilerini_Aktar()
    Dim Son As Long, X As Long, Bul As Range, Say As Byte, Adres As String
    Dim Satir As Long, Y As Long, Veri As Range, Zaman As Double
    
    Zaman = Timer
    
    Son = Cells(Rows.Count, "C").End(3).Row
    Range("I7:J" & Rows.Count).ClearContents
    With Range("I7:I" & Son)
        .NumberFormat = "General"
        .Formula = "=C7&""-""&D7&""-""&E7&""-""&F7&""-""&G7&""-""&H7"
        .NumberFormat = "@"
        .Value = .Value
    End With

    Son = Cells(Rows.Count, "S").End(3).Row
    Range("W7:W" & Rows.Count).ClearContents
    With Range("W7:W" & Son)
        .NumberFormat = "General"
        .Formula = "=S7&""-""&T7&""-""&U7&""-""&V7"
        .NumberFormat = "@"
        .Value = .Value
    End With

    Range("AA7:AF" & Rows.Count).ClearContents
    Satir = 7
    
    For X = 7 To Son
        For Y = 7 To Satir
            Say = 0
            For Each Veri In Range("S" & X & ":V" & X)
                If WorksheetFunction.CountIf(Range("AA" & Y & ":AF" & Y), Veri) > 0 Then
                    Say = Say + 1
                End If
            Next
            If Say = 4 Then
                GoTo 10
            End If
        Next

        Set Bul = Range("I:I").Find(Cells(X, "W"))
        If Not Bul Is Nothing Then
            Adres = Bul.Address
            Do
                If Cells(Bul.Row, "J") <> "OK" Then
                    Range("AA" & Satir & ":AF" & Satir).Value = Range("C" & Bul.Row & ":H" & Bul.Row).Value
                    Cells(Bul.Row, "J") = "OK"
                    Satir = Satir + 1
                    Exit Do
                End If
                Set Bul = Range("I:I").FindNext(Bul)
            Loop While Not Bul Is Nothing And Bul.Address <> Adres
        End If
10  Next

    MsgBox "İşleminiz tamamlanmıştır." & Chr(10) & "İşlem süresi ; " & Format(Timer - Zaman, "0.00") & " Saniye", vbInformation
End Sub
 
Kodu güncelledim. Yanlış kurgu yapıyorum sanırım. Bendeki kurguya göre çok fazla dizi listeleniyor.

Deneyip sonucu bildirir misiniz?
 
Gerçekten özür dilerim hocam sizin değil benim kurgumda hata var.. :oops:

kurguyu düzeltip sizin verdiğiniz kodla tekrar deneyip buradan sonucu paylaşacağım..

Zaman ayırıp emek verdiğiniz için ayrıca tşk ederim, kusurumu bağışlayın...
 
Son düzenleme:
Durum şu hocam:

Yaptığınız kod doğru olarak çalışıyor.

4 lü dizide 1-2-4-7 ye geldiği zaman haklı olarak 6 lı dizide ilk gelen dizi olan 1-2-4-7-8-9 dizisini seçiyor ancak burada bir kural daha var.

6.SEÇİM 1 2 4 7 8 9 dizisi içindeki koyulaştırdığım rakamlar daha önce seçilen 2.SEÇİM de 1 2 3 7 8 9 benzer şekilde 4 lü dizi şeklinde tekerrür ettiği için hatalı seçilim yapılmış oluyor. (bu örnekte 5 li tekerrür var).

Yani 1-2-4-7 dizisi tekerrüre sebebiyet verdiği için geçilmeli ve daha önce seçilenlerde kendi içinde 4 lü dizi halinde tekerrür etmemeli.
 
Son düzenleme:
Deneyiniz.

Son belirttiğiniz kuralı koda entegre etmeye çalıştım.

Kod bu haliyle 96 satır veri listeliyor.

İnceleyin. Sorun varsa yeniden kurgularız.

3 lü sorgulama mantığı olduğu için işlem süresi biraz uzadı.

Kod: 
Option Explicit

Sub Sayi_Dizilerini_Aktar()
    Dim Son As Long, X As Long, Bul As Range, Say As Byte, Adres As String
    Dim Satir As Long, Y As Long, Veri As Range, Zaman As Double
    
    Zaman = Timer
    
    Son = Cells(Rows.Count, "C").End(3).Row
    Range("I7:J" & Rows.Count).ClearContents
    With Range("I7:I" & Son)
        .NumberFormat = "General"
        .Formula = "=C7&""-""&D7&""-""&E7&""-""&F7&""-""&G7&""-""&H7"
        .NumberFormat = "@"
        .Value = .Value
    End With

    Son = Cells(Rows.Count, "S").End(3).Row
    Range("W7:W" & Rows.Count).ClearContents
    With Range("W7:W" & Son)
        .NumberFormat = "General"
        .Formula = "=S7&""-""&T7&""-""&U7&""-""&V7"
        .NumberFormat = "@"
        .Value = .Value
    End With

    Range("AA7:AF" & Rows.Count).ClearContents
    Satir = 7
    
    For X = 7 To Son
        For Y = 7 To Satir
            Say = 0
            For Each Veri In Range("S" & X & ":V" & X)
                If WorksheetFunction.CountIf(Range("AA" & Y & ":AF" & Y), Veri) > 0 Then
                    Say = Say + 1
                End If
            Next
            If Say = 4 Then
                GoTo 10
            End If
        Next

        Set Bul = Range("I:I").Find(Cells(X, "W"))
        If Not Bul Is Nothing Then
            Adres = Bul.Address
            Do
                If Cells(Bul.Row, "J") <> "OK" Then
                    For Y = 7 To Satir
                        If Cells(Y, "AA") <> "" Then
                            Say = 0
                            For Each Veri In Range("C" & Bul.Row & ":H" & Bul.Row)
                                If WorksheetFunction.CountIf(Range("AA" & Y & ":AF" & Y), Veri) > 0 Then
                                    Say = Say + 1
                                End If
                            Next
                            If Say >= 4 Then
                                GoTo 20
                            End If
                        End If
                    Next
                    
                    Range("AA" & Satir & ":AF" & Satir).Value = Range("C" & Bul.Row & ":H" & Bul.Row).Value
                    Cells(Bul.Row, "J") = "OK"
                    Satir = Satir + 1
                    Exit Do
                End If
20
                Set Bul = Range("I:I").FindNext(Bul)
            Loop While Not Bul Is Nothing And Bul.Address <> Adres
        End If
10
    Next

    MsgBox "İşleminiz tamamlanmıştır." & Chr(10) & "İşlem süresi ; " & Format(Timer - Zaman, "0.00") & " Saniye", vbInformation
End Sub
 
Hocam herhangi bir 4 lü dizi tekerrüre sebebiyet verdiği anda o 4 lü diziyi eliyoruz, kullanmıyoruz.

Yani 1-2-4-7 daha önce tekerrüre sebep olmuştu, bu yüzden içinde 1-2-4-7 olan tüm 6 lı dizileri kullanmayacağız. Mantık bu.

Konu biraz genişler gibi oldu, şayet bu şekilde sonuca ulaşamazsak , algoritma akışını görsel olarak hazırlayıp paylaşırım buradan.
 
Birde aşağıdaki kodu deneyiniz.

Kod: 
Option Explicit

Sub Sayi_Dizilerini_Aktar()
    Dim Son As Long, X As Long, Bul As Range, Say As Byte, Adres As String
    Dim Satir As Long, Y As Long, Veri As Range, Zaman As Double
    
    Zaman = Timer
    
    Son = Cells(Rows.Count, "C").End(3).Row
    Range("I7:J" & Rows.Count).ClearContents
    With Range("I7:I" & Son)
        .NumberFormat = "General"
        .Formula = "=C7&""-""&D7&""-""&E7&""-""&F7&""-""&G7&""-""&H7"
        .NumberFormat = "@"
        .Value = .Value
    End With

    Son = Cells(Rows.Count, "S").End(3).Row
    Range("W7:W" & Rows.Count).ClearContents
    With Range("W7:W" & Son)
        .NumberFormat = "General"
        .Formula = "=S7&""-""&T7&""-""&U7&""-""&V7"
        .NumberFormat = "@"
        .Value = .Value
    End With

    Range("AA7:AF" & Rows.Count).ClearContents
    Satir = 7
    
    For X = 7 To Son
        For Y = 7 To Satir
            Say = 0
            For Each Veri In Range("S" & X & ":V" & X)
                If WorksheetFunction.CountIf(Range("AA" & Y & ":AF" & Y), Veri) > 0 Then
                    Say = Say + 1
                End If
            Next
            If Say = 4 Then
                GoTo 10
            End If
        Next

        Set Bul = Range("I:I").Find(Cells(X, "W"))
        If Not Bul Is Nothing Then
            Adres = Bul.Address
            Do
                If Cells(Bul.Row, "J") <> "OK" Then
                    For Y = 7 To Satir
                        If Cells(Y, "AA") <> "" Then
                            Say = 0
                            For Each Veri In Range("C" & Bul.Row & ":H" & Bul.Row)
                                If WorksheetFunction.CountIf(Range("AA" & Y & ":AF" & Y), Veri) > 0 Then
                                    Say = Say + 1
                                End If
                            Next
                            If Say >= 4 Then
                                Cells(Bul.Row, "J") = "OK"
                                GoTo 20
                            End If
                        End If
                    Next
                    
                    Range("AA" & Satir & ":AF" & Satir).Value = Range("C" & Bul.Row & ":H" & Bul.Row).Value
                    Cells(Bul.Row, "J") = "OK"
                    Satir = Satir + 1
                    Exit Do
                End If
20
                Set Bul = Range("I:I").FindNext(Bul)
            Loop While Not Bul Is Nothing And Bul.Address <> Adres
        End If
10
    Next

    MsgBox "İşleminiz tamamlanmıştır." & Chr(10) & "İşlem süresi ; " & Format(Timer - Zaman, "0.00") & " Saniye", vbInformation
End Sub
 
olmadı hocam, algoritma akışını görsel olarak hazırlayıp ekleyeceğim.
 
Hocam algoritma akışını görsel olarak hazırladım ve tertemiz bir sayfa açtım ve eminim işiniz çok çok kolaylaştı, kurgunun doğruluk oranıda %59,99 :rolleyes: :gidiyorum:
 

Ekli dosyalar

Son düzenleme:
Merhaba,

Siz Sayısal yada Süper lotodaki olasılıklardan 4 benzer olanları elesin mi istiyorsunuz özet olarak?
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst