SQL Sorguda adet sayısına göre kayıt getirme ..

[tamer42]

Merhabalar,

Ekli dosyada 6 sütun ve 487 satır; her bir hücrede 0, 1, 2 değerleri bulunmakta

burada oluşturmak istediğim sorgu:
Toplam 10 adet kayıt getirecek,

x1: alanında 1 : 5 adet , 0 : 2 adet , 2 : 3 adet (5+2+3=10)
x2: alanında 1 : 3 adet , 0 : 4 adet , 2 : 3 adet (3+4+3=10)

eğer bu kurala uyacak 10 kayıt bulamazsa, 9, 8, 7, .... ne kadar eşleştirebilirse o kadar getirebilir.

bu kurala uygun sorgu nasıl düzenlebilir?

Sub sorguu()
Dim Con As Object
Dim Sorgu As String
Dim yol As String


Set Con = VBA.CreateObject("adodb.Connection")

yol = ThisWorkbook.FullName

Sayfa2.Activate
Sayfa2.Cells.ClearContents

Con.Open "provider=microsoft.ace.oledb.12.0;data source=" & _
yol & ";extended properties=""Excel 12.0;hdr=yes"""

Sorgu = "Select * From [Data$] Where x1=1 And x2=1"

Set RS = Con.Execute(Sorgu)

Sayfa2.Range("A2").CopyFromRecordset RS

x = 1
For Each baslik In RS.Fields
        Sayfa2.Cells(1, x) = baslik.Name
        x = x + 1
Next baslik

Con.Close

End Sub

yardımlarınız için şimdiden teşekkürler,
iyi çalışmalar.

 

[haliliyas]

Dosyayı harici bir siteye yükler misiniz

 

[tamer42]

Dosyayı harici bir siteye yükler misiniz

Buyurun Hocam ..

https://dosya.co/jiphsfw583j4/Kitap12.xlsm.html

 

[haliliyas]

soruyu tam olarak anlamadım, örnek veriler üzerinden biraz daha açıklar mısınız?
sadece x1 ve x2 alanları için mi işlem yapılacak?

x1: alanında 1 : 5 adet , 0 : 2 adet , 2 : 3 adet (5+2+3=10)
x2: alanında 1 : 3 adet , 0 : 4 adet , 2 : 3 adet (3+4+3=10)

sorgunuzda x1 ve x2 için kriter koymuşsunuz ama kriter koyulunca diğer değerler 0 ve 2 nasıl sayılacak?

 

[tamer42]

soruyu tam olarak anlamadım, örnek veriler üzerinden biraz daha açıklar mısınız?
sadece x1 ve x2 alanları için mi işlem yapılacak?

sorgunuzda x1 ve x2 için kriter koymuşsunuz ama kriter koyulunca diğer değerler 0 ve 2 nasıl sayılacak?

Halil Hocam sadece x1 ve x2 alanlarında değerler sayılacak, diğer alanlar önemli değil; toplam (en fazla) 10 kayıt gelecek

   Sorgu = "Select [x1],[x2] From [Data$]"

olarak ta düşünebilirsiniz
sorgu sonucunda elde edilecek 10 kayıtın;
x1 alanında 1,0 ve 2 den belirtilen adette kayıt, aynı anda x2 alanında 1,0 ve 2 den belirtilen adette kayıt olacak

sanırım anlatabilmişimdir.
ilginize tekrar teşekkürler, iyi çalışmalar.

 

[haliliyas]

aşağıdakine benzer bir sorgu işinize yarar mı?

Sorgu = Sorgu & "Select top 3 * From [Data$] Where x1=1 And x2=1 " & vbNewLine & "union all " & vbNewLine
Sorgu = Sorgu & "Select top 2 * From [Data$] Where x1=1 And x2<>1 " & vbNewLine & "union all " & vbNewLine
Sorgu = Sorgu & "Select top 2 * From [Data$] Where x1=0 And x2=0 " & vbNewLine & "union all " & vbNewLine
Sorgu = Sorgu & "Select top 2 * From [Data$] Where x2=0 And x1<>0" & vbNewLine & "union all " & vbNewLine
Sorgu = Sorgu & "Select top 3 * From [Data$] Where x1=2 And x2=2 "

 

[haliliyas]

eğer bu kod işinize yarıyorsa aynı temel mantığı kullanarak ayarlar sayfasındaki isteğe göre kodda ayarlamalar yapılabilir.

 

[tamer42]

aşağıdakine benzer bir sorgu işinize yarar mı?

Sorgu = Sorgu & "Select top 3 * From [Data$] Where x1=1 And x2=1 " & vbNewLine & "union all " & vbNewLine
Sorgu = Sorgu & "Select top 2 * From [Data$] Where x1=1 And x2<>1 " & vbNewLine & "union all " & vbNewLine
Sorgu = Sorgu & "Select top 2 * From [Data$] Where x1=0 And x2=0 " & vbNewLine & "union all " & vbNewLine
Sorgu = Sorgu & "Select top 2 * From [Data$] Where x2=0 And x1<>0" & vbNewLine & "union all " & vbNewLine
Sorgu = Sorgu & "Select top 3 * From [Data$] Where x1=2 And x2=2 "

Halil Hocam Hocam hemen kontrol edip dönüş yapıyorum size
şimdiden teşekkürler

 

[tamer42]

Halil Hocam Hocam hemen kontrol edip dönüş yapıyorum size
şimdiden teşekkürler

Halil Hocam ekli dosyadaki gibi toplam 10 kayıt yerine; toplam 12 kayıt getirdi, dolayısıyla gelen kayıtlarda 1,0 ve 2 den beklediğim değerlerin bazıları bir kaç fazla geldi.

https://dosya.co/1o8d8qrrjgyu/Kitap12.xlsm.html

ilginize tekrar teşekkürler,

 

[haliliyas]

Sorgu ile en fazla bukadar olabilir gibime geliyor maalesef aklıma başka birşey gelmiyor, sorguyla gelen bu değerler diziye aktarılıp fazlalıklar çıkarılabilir.

 

[tamer42]

Sorgu ile en fazla bukadar olabilir gibime geliyor maalesef aklıma başka birşey gelmiyor, sorguyla gelen bu değerler diziye aktarılıp fazlalıklar çıkarılabilir.

Tamamdır
tekrar teşekkürler Halil Hocam

 

[haliliyas]

farklı bir yol buldum ama biraz uzun sürüyor
isterdeniz deneyin

Sub SorguAdet_hy3_1()
Dim Con As Object
Dim Sorgu As String
Dim yol As String
Application.ScreenUpdating = False

Set Con = VBA.CreateObject("adodb.Connection")

yol = ThisWorkbook.FullName

Sayfa2.Activate
Sayfa2.Cells.ClearContents

Con.Open "provider=microsoft.ace.oledb.12.0;data source=" & _
yol & ";extended properties=""Excel 12.0;hdr=yes"""

Sorgu = Sorgu & "Select top 3 * From [Data$] Where x1=1 And x2=1 " & vbNewLine & "union all " & vbNewLine
Sorgu = Sorgu & "Select top 2 * From [Data$] Where x1=0 And x2=0 " & vbNewLine & "union all " & vbNewLine
Sorgu = Sorgu & "Select top 3 * From [Data$] Where x1=2 And x2=2 "

Set rs = Con.Execute(Sorgu)
Sayfa2.Range("A2").CopyFromRecordset rs
x = 1
For Each baslik In rs.Fields
    Sayfa2.Cells(1, x) = baslik.Name
    x = x + 1
Next baslik
rs.Close

Sorgu = "Select * From [Data$] Where x1<>x2 "

'____________________________________
Set rsH = CreateObject("adodb.recordset")
    rsH.CursorType = 1 ' adOpenKeyset
    rsH.LockType = 3   ' adLockOptimistic
    rsH.Open "select * from [Rapor$]", Con ', 1, 3

Set RsK = Con.Execute(Sorgu)

        With RsK 'loop
        If Not .BOF And Not .EOF Then
                .MoveFirst
                While (Not .EOF)
                rsH.addnew
                    For x = 0 To rsH.Fields.Count - 1
                        rsH(x) = RsK(x)
                    Next x
                  rsH.Update

xSil = False

rsH.Filter = "x1=1": If rsH.RecordCount > 5 Then xSil = True: GoTo 10
rsH.Filter = "x1=0": If rsH.RecordCount > 2 Then xSil = True: GoTo 10
rsH.Filter = "x1=2": If rsH.RecordCount > 3 Then xSil = True: GoTo 10
rsH.Filter = "x2=1": If rsH.RecordCount > 3 Then xSil = True: GoTo 10
rsH.Filter = "x2=0": If rsH.RecordCount > 4 Then xSil = True: GoTo 10
rsH.Filter = "x2=2": If rsH.RecordCount > 3 Then xSil = True: GoTo 10
10
                 If xSil Then
                 rsH.movelast
                    rsH(0) = Null
                    rsH(1) = Null
                    rsH.Update
                 End If
                .MoveNext
                Wend
        End If
        End With

Sorgu = "select * from [Rapor$] Where x1<>null "
rsH.Filter = ""
rsH.Close
rsH.CursorLocation = 3
rsH.Open Sorgu, Con ', 1, 3

Sayfa2.UsedRange.Offset(1).Cells.ClearContents
Sayfa2.Range("A2").CopyFromRecordset rsH

Con.Close
Application.ScreenUpdating = True
End Sub

basitleştirip hızlandırmak için çalışıyorum
ara ara konuyu kontrol edebilirseniz belki daha uygun kod bulunabilir

 

[haliliyas]

bu arada ayarlar sayfasındaki değerler değişken mi?

 

[haliliyas]

son hali )

Sub SorguAdet_hy_5()
Dim Con As Object
Dim Sorgu As String
Dim yol As String
Application.ScreenUpdating = False

Set Con = VBA.CreateObject("adodb.Connection")

yol = ThisWorkbook.FullName

Sayfa2.Activate
Sayfa2.Cells.ClearContents
'___________________________________________________________

Set dict = CreateObject("Scripting.Dictionary")
    dict.Add 1, Array(5, 3)
    dict.Add 0, Array(2, 4)
    dict.Add 2, Array(3, 3)
'___________________________________________________________

Con.Open "provider=microsoft.ace.oledb.12.0;data source=" & _
yol & ";extended properties=""Excel 12.0;hdr=yes"""

Sorgu = Sorgu & "Select top 3 * From [Data$] Where x1=1 And x2=1 " & vbNewLine & "union all " & vbNewLine
Sorgu = Sorgu & "Select top 2 * From [Data$] Where x1=0 And x2=0 " & vbNewLine & "union all " & vbNewLine
Sorgu = Sorgu & "Select top 3 * From [Data$] Where x1=2 And x2=2 "

Set rs = Con.Execute(Sorgu)
Sayfa2.Range("A2").CopyFromRecordset rs
x = 1
For Each baslik In rs.Fields
    Sayfa2.Cells(1, x) = baslik.Name
    x = x + 1
Next baslik
rs.Close

Sorgu = "Select * From [Data$] Where x1<>x2 "

'____________________________________
Set rsH = CreateObject("adodb.recordset")
    rsH.CursorType = 1 ' adOpenKeyset
    rsH.LockType = 3   ' adLockOptimistic
    rsH.Open "select * from [Rapor$]", Con ', 1, 3

Set RsK = Con.Execute(Sorgu)

        With RsK 'loop
            If Not .BOF And Not .EOF Then
            .MoveFirst
                While (Not .EOF)
                xEkle = True
                    rsH.Filter = "x1=" & RsK("x1"): If rsH.RecordCount = dict(Val(RsK("x1")))(0) Then xEkle = False: GoTo 10
                    rsH.Filter = "x2=" & RsK("x2"): If rsH.RecordCount = dict(Val(RsK("x2")))(1) Then xEkle = False: GoTo 10
10
                    If xEkle Then
                    rsH.addnew
                        For x = 0 To rsH.Fields.Count - 1
                            rsH(x) = RsK(x)
                        Next x
                    rsH.Update
                    End If
                .MoveNext
                Wend
            End If
        End With
Con.Close
Application.ScreenUpdating = True
End Su

 

[dost]

Merhaba,

x1    x2    x3    x4    x5    x6
1    0    ---    ---    ---    ---
1    0    ---    ---    ---    ---
1    0    ---    ---    ---    ---
1    0    ---    ---    ---    ---
1    1    ---    ---    ---    ---
0    1    ---    ---    ---    ---
0    1    ---    ---    ---    ---
2    2    ---    ---    ---    ---
2    2    ---    ---    ---    ---
2    2    ---    ---    ---    ---

x1 bu şeklide olacak, x2'nin sıralaması önemli değil ama (0=4, 1=3, 2=3 adet olacak) x3, x4, x5, x6 nın değerlerinin önemi yok. Bu kominasyonda da en fazla 10 satır olacak.

Anladığım doğru mu?

 

[tamer42]

bu arada ayarlar sayfasındaki değerler değişken mi?

Doğrudur Hocam

 

[tamer42]

Merhaba,

x1    x2    x3    x4    x5    x6
1    0    ---    ---    ---    ---
1    0    ---    ---    ---    ---
1    0    ---    ---    ---    ---
1    0    ---    ---    ---    ---
1    1    ---    ---    ---    ---
0    1    ---    ---    ---    ---
0    1    ---    ---    ---    ---
2    2    ---    ---    ---    ---
2    2    ---    ---    ---    ---
2    2    ---    ---    ---    ---

x1 bu şeklide olacak, x2'nin sıralaması önemli değil ama (0=4, 1=3, 2=3 adet olacak) x3, x4, x5, x6 nın değerlerinin önemi yok. Bu kominasyonda da en fazla 10 satır olacak.

Anladığım doğru mu?

Doğrudur Hocam ..
Teşekkürler

 

[tamer42]

son hali )

Sub SorguAdet_hy_5()
Dim Con As Object
Dim Sorgu As String
Dim yol As String
Application.ScreenUpdating = False

Set Con = VBA.CreateObject("adodb.Connection")

yol = ThisWorkbook.FullName

Sayfa2.Activate
Sayfa2.Cells.ClearContents
'___________________________________________________________

Set dict = CreateObject("Scripting.Dictionary")
    dict.Add 1, Array(5, 3)
    dict.Add 0, Array(2, 4)
    dict.Add 2, Array(3, 3)
'___________________________________________________________

Con.Open "provider=microsoft.ace.oledb.12.0;data source=" & _
yol & ";extended properties=""Excel 12.0;hdr=yes"""

Sorgu = Sorgu & "Select top 3 * From [Data$] Where x1=1 And x2=1 " & vbNewLine & "union all " & vbNewLine
Sorgu = Sorgu & "Select top 2 * From [Data$] Where x1=0 And x2=0 " & vbNewLine & "union all " & vbNewLine
Sorgu = Sorgu & "Select top 3 * From [Data$] Where x1=2 And x2=2 "

Set rs = Con.Execute(Sorgu)
Sayfa2.Range("A2").CopyFromRecordset rs
x = 1
For Each baslik In rs.Fields
    Sayfa2.Cells(1, x) = baslik.Name
    x = x + 1
Next baslik
rs.Close

Sorgu = "Select * From [Data$] Where x1<>x2 "

'____________________________________
Set rsH = CreateObject("adodb.recordset")
    rsH.CursorType = 1 ' adOpenKeyset
    rsH.LockType = 3   ' adLockOptimistic
    rsH.Open "select * from [Rapor$]", Con ', 1, 3

Set RsK = Con.Execute(Sorgu)

        With RsK 'loop
            If Not .BOF And Not .EOF Then
            .MoveFirst
                While (Not .EOF)
                xEkle = True
                    rsH.Filter = "x1=" & RsK("x1"): If rsH.RecordCount = dict(Val(RsK("x1")))(0) Then xEkle = False: GoTo 10
                    rsH.Filter = "x2=" & RsK("x2"): If rsH.RecordCount = dict(Val(RsK("x2")))(1) Then xEkle = False: GoTo 10
10
                    If xEkle Then
                    rsH.addnew
                        For x = 0 To rsH.Fields.Count - 1
                            rsH(x) = RsK(x)
                        Next x
                    rsH.Update
                    End If
                .MoveNext
                Wend
            End If
        End With

Sorgu = "select * from [Rapor$] Where x1<>null "
rsH.Filter = ""
rsH.Close
rsH.CursorLocation = 3
rsH.Open Sorgu, Con ', 1, 3

Sayfa2.UsedRange.Offset(1).Cells.ClearContents
Sayfa2.Range("A2").CopyFromRecordset rsH

Con.Close
Application.ScreenUpdating = True
End Su

Müsait olunca ilk fırsaata deneyeceğim Hocam
Çok teşekkür ederim, emeğinize sağlık!

 

[haliliyas]

14. mesajdaki kodu güncelledim fazlalıklar vardı sildim

 

[haliliyas]

kodun son hali, x1 için sıralama işlemi yok

Sub SorguAdet_hy_5_2()
Dim Con As Object
Dim Sorgu As String
Dim yol As String
Application.ScreenUpdating = False

Set Con = VBA.CreateObject("adodb.Connection")

yol = ThisWorkbook.FullName

Sayfa2.Activate
Sayfa2.Cells.ClearContents

'___________________________________________________________
'Dim DzK() As Variant
'DzK = Sayfa3.Range("A1:C4")
Set dict = CreateObject("Scripting.Dictionary")
    dict.Add 1, Array(5, 3)
    dict.Add 0, Array(2, 4)
    dict.Add 2, Array(3, 3)
'___________________________________________________________

Con.Open "provider=microsoft.ace.oledb.12.0;data source=" & _
yol & ";extended properties=""Excel 12.0;hdr=yes"""

Sorgu = Sorgu & "Select top 3 * From [Data$] Where x1=1 And x2=1 " & vbNewLine & "union all " & vbNewLine
Sorgu = Sorgu & "Select top 2 * From [Data$] Where x1=0 And x2=0 " & vbNewLine & "union all " & vbNewLine
Sorgu = Sorgu & "Select top 3 * From [Data$] Where x1=2 And x2=2 "

Set rs = Con.Execute(Sorgu)
Sayfa2.Range("A2").CopyFromRecordset rs
x = 1
For Each baslik In rs.Fields
    Sayfa2.Cells(1, x) = baslik.Name
    x = x + 1
Next baslik
rs.Close

Sorgu = "Select * From [Data$] Where x1<>x2 "

'____________________________________
Set rsH = CreateObject("adodb.recordset")
    rsH.CursorType = 1 ' adOpenKeyset
    rsH.LockType = 3   ' adLockOptimistic
    rsH.Open "select * from [Rapor$]", Con ', 1, 3

Set RsK = Con.Execute(Sorgu)

        With RsK 'loop
            If Not .BOF And Not .EOF Then
            .MoveFirst
                While (Not .EOF)
                    rsH.Filter = "x1=" & RsK("x1"): If rsH.RecordCount = dict(Val(RsK("x1")))(0) Then GoTo 10
                    rsH.Filter = "x2=" & RsK("x2"): If rsH.RecordCount = dict(Val(RsK("x2")))(1) Then GoTo 10
                    rsH.addnew
                        For x = 0 To rsH.Fields.Count - 1
                            rsH(x) = RsK(x)
                        Next x
                    rsH.Update
10
                .MoveNext
                Wend
            End If
        End With

Con.Close
Application.ScreenUpdating = True
End Sub