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

tamer42 · 15 Ocak 2025

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?

Kod:

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 · 15 Ocak 2025

Dosyayı harici bir siteye yükler misiniz

tamer42 · 15 Ocak 2025

haliliyas' Alıntı:
Dosyayı harici bir siteye yükler misiniz

Buyurun Hocam ..

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

haliliyas · 15 Ocak 2025

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?

tamer42' Alıntı:
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 · 15 Ocak 2025

haliliyas' Alıntı:
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

Kod:

   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 · 15 Ocak 2025

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

Kod:

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 · 15 Ocak 2025

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

tamer42 · 15 Ocak 2025

haliliyas' Alıntı:

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

Kod:

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 · 15 Ocak 2025

tamer42' Alıntı:
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 · 15 Ocak 2025

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 · 15 Ocak 2025

haliliyas' Alıntı:
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 · 15 Ocak 2025

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

Kod:

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 · 15 Ocak 2025

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

haliliyas · 15 Ocak 2025

son hali )

Kod:

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 · 15 Ocak 2025

Merhaba,

Kod:

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 · 15 Ocak 2025

haliliyas' Alıntı:
bu arada ayarlar sayfasındaki değerler değişken mi?

Doğrudur Hocam

tamer42 · 15 Ocak 2025

dost' Alıntı:
Merhaba,

Kod:

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 · 15 Ocak 2025

haliliyas' Alıntı:

son hali )

Kod:

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 · 15 Ocak 2025

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

haliliyas · 15 Ocak 2025

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

Kod:

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

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

tamer42

Destek Ekibi

Ekli dosyalar

haliliyas

tamer42

Destek Ekibi

haliliyas

tamer42

Destek Ekibi

haliliyas

haliliyas

tamer42

Destek Ekibi

tamer42

Destek Ekibi

haliliyas

tamer42

Destek Ekibi

haliliyas

haliliyas

haliliyas

dost

tamer42

Destek Ekibi

tamer42

Destek Ekibi

tamer42

Destek Ekibi

haliliyas

haliliyas