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

tamer42 · 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

Çok teşekkür ederim Halil Hocam iyiki varsınız!

şimdi benim bu alagoritmayı iyice bir içselleştirdikten sonra biraz geliştirmek istiyorum.
Örnek: şimdiye kadar 2. alanı (x1, x2) kontrol ediyorduk, şimdi bana düşen aynı şekilde 3. alanı da (x3) buraya entegre etmek olacak

Selamlar, Saygılar.

haliliyas · 15 Ocak 2025

rica ederim
iyi çalışmalar)
takıldığınız, anlamadığınız yer olursa sorabilirsiniz

haliliyas · 15 Ocak 2025

aklıma gelmişken belirteyim eğer 2den fazla alan için yapılacaksa kodların baya değişmesi gerekebilir en azından kodun ilk kısmı yani şu "select top ..." kısmı devre dışı kalır ki o kısım işi baya kolaylaştırıyordu

tamer42 · 15 Ocak 2025

haliliyas' Alıntı:
aklıma gelmişken belirteyim eğer 2den fazla alan için yapılacaksa kodların baya değişmesi gerekebilir en azından kodun ilk kısmı yani şu "select top ..." kısmı devre dışı kalır ki o kısım işi baya kolaylaştırıyordu

İlyas Hocam 3' lü seçenekle nasıl olur?
Yol gösterirseniz sevinirim.

x3' ün değerleri aşağıdaki gibi olabilir, farklı şekilde de olabilir...
x3: alanında 1 : 2 adet , 0 : 5 adet , 2 : 3 adet (2+5+3=10)

Anlayışınız ve sabrınız için gerçekten çok teşekkür derim.

Bu süreçte sabırlı kalma yeteneğiniz gerçekten takdire şayan!

haliliyas · 15 Ocak 2025

aşağıdaki kod işinize yarayabilir ama maalesef sonuç her zaman tam çıkmıyor
data sayfasındaki verileri karıştırıp denediğimde bazen tam 10 sayı verdi bazen 9

Kod:

Sub SorguAdet_hy_6()
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.Clear
'___________________________________________________________

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

Sorgu = "Select * From [Data$]"
    Set rs = Con.Execute(Sorgu)
    Sayfa2.Range("A2").CopyFromRecordset rs
    Sayfa2.Cells.ClearContents

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

SorguA = "Select * From [Ayarlar$] Where F1 & ''<>''"
Set RsA = Con.Execute(SorguA)
'____________________________________
Set rsH = CreateObject("adodb.recordset")
    rsH.CursorType = 1 ' adOpenKeyset
    rsH.LockType = 3   ' adLockOptimistic
    rsH.Open "select * from [Rapor$]", Con ', 1, 3
   
Sorgu = "Select * From [Data$]"
Set RsK = Con.Execute(Sorgu)

        With RsK
            If Not .BOF And Not .EOF Then
            .movefirst
                While (Not .EOF)
             
                For x = 1 To RsA.Fields.Count - 1
                RsA.Filter = RsA(0).Name & "=" & RsK(RsA(x).Name)
                    rsH.Filter = RsA(x).Name & "=" & RsK(RsA(x).Name): If rsH.RecordCount = RsA(x) Then GoTo 10
                Next x
                    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

tamer42 · 15 Ocak 2025

haliliyas' Alıntı:

aşağıdaki kod işinize yarayabilir ama maalesef sonuç her zaman tam çıkmıyor
data sayfasındaki verileri karıştırıp denediğimde bazen tam 10 sayı verdi bazen 9

Kod:

Sub SorguAdet_hy_6()
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.Clear
'___________________________________________________________

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

Sorgu = "Select * From [Data$]"
    Set rs = Con.Execute(Sorgu)
    Sayfa2.Range("A2").CopyFromRecordset rs
    Sayfa2.Cells.ClearContents

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

SorguA = "Select * From [Ayarlar$] Where F1 & ''<>''"
Set RsA = Con.Execute(SorguA)
'____________________________________
Set rsH = CreateObject("adodb.recordset")
    rsH.CursorType = 1 ' adOpenKeyset
    rsH.LockType = 3   ' adLockOptimistic
    rsH.Open "select * from [Rapor$]", Con ', 1, 3
 
Sorgu = "Select * From [Data$]"
Set RsK = Con.Execute(Sorgu)

        With RsK
            If Not .BOF And Not .EOF Then
            .movefirst
                While (Not .EOF)
           
                For x = 1 To RsA.Fields.Count - 1
                RsA.Filter = RsA(0).Name & "=" & RsK(RsA(x).Name)
                    rsH.Filter = RsA(x).Name & "=" & RsK(RsA(x).Name): If rsH.RecordCount = RsA(x) Then GoTo 10
                Next x
                    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

1- 2 puan o kadar önemli değil Hocam,
sabrınız ve yardımalrınız için çok teşekkürler

Sağ olun, var olun....

haliliyas · 15 Ocak 2025

sayı tutmadığı zaman DATA sayfasındaki her hangi bir alana göre sıralamayı değiştirip deneyebilirsiniz
rica ederim
iyi çalışmalar

haliliyas · 15 Ocak 2025

ayarlardaki tüm sütunların toplamı aynı mı?
bir sütunda 2+5+3=10 ise diğerleri de 10 mu

haliliyas · 15 Ocak 2025

aşağıdaki kod istenen kayıt sayısı tutmayınca işlemi xDonguMax kadar döngüye sokuyor, bazen 20 defa da bile çıkmıyor
kodu tekrar çalıştırmak gerekiyor

Kod:

Sub SorguAdet_hy_6_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.Clear
'___________________________________________________________

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

Sorgu = "Select * From [Data$]"
    Set rs = Con.Execute(Sorgu)
    
    
    Sayfa2.Range("A2").CopyFromRecordset rs
    Sayfa2.Cells.ClearContents
Dim dzBaslik As Variant
ReDim dzBaslik(1 To rs.Fields.Count)
Set dict = CreateObject("Scripting.Dictionary")
    x = 1
    For Each baslik In rs.Fields
        Sayfa2.Cells(1, x) = baslik.Name
        dzBaslik(x) = baslik.Name
        x = x + 1
    Next baslik
    rs.Close

SorguA = "Select * From [Ayarlar$] Where not isnull(F1) "
Set RsA = Con.Execute(SorguA)
With RsA
    If Not .BOF And Not .EOF Then
    .movefirst
        While (Not .EOF)
        xKaytSay = xKaytSay + .Fields(1).Value
        .MoveNext
        Wend
    End If
End With


'____________________________________
Set rsH = CreateObject("adodb.recordset")
    rsH.CursorType = 1 ' adOpenKeyset
    rsH.LockType = 3   ' adLockOptimistic
    rsH.Open "select * from [Rapor$]", Con ', 1, 3
Sorgu = "Select * From [Data$]" ' order by " & dict(xSira) & xAsc

Set RsK = CreateObject("adodb.recordset")
    RsK.CursorLocation = 3
    RsK.Open Sorgu, Con ', 1, 3
xDonguMax = 20 'doğru adeti bulana kadar tekrarlama sayısı
xBas:
xDonguSay = xDonguSay + 1
 
 For xD = LBound(dzBaslik) To UBound(dzBaslik)
 Randomize: xAsc = Choose(Int((2 - 1 + 1) * Rnd + 1), " asc", " desc")
         dict.Add xD, dzBaslik(xD) & xAsc
 Next xD
 xSort = ""
        For yStn = 1 To dict.Count
            Randomize: xDgr = Int(Rnd * (dict.Count))
            xSort = xSort & ", " & dict.Items()(xDgr)
            dict.Remove dict.keys()(xDgr)
        Next yStn
        
             RsK.Sort = Mid(xSort, 3)
        With RsK
            If Not .BOF And Not .EOF Then
            .movefirst
                While (Not .EOF)
              
                    For x = 1 To RsA.Fields.Count - 1
                    RsA.Filter = RsA(0).Name & "=" & RsK(RsA(x).Name)
                        rsH.Filter = RsA(x).Name & "=" & RsK(RsA(x).Name): If rsH.RecordCount = RsA(x) Then GoTo 10
                    Next x
                    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
rsH.Filter = ""
'Debug.Print xDonguSay, xKaytSay & "<>" & rsH.RecordCount, Mid(xSort, 3)
If xKaytSay <> rsH.RecordCount And xDonguSay <= xDonguMax Then GoTo xBas
Con.Close
Application.ScreenUpdating = True
End Sub

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

tamer42

Destek Ekibi

haliliyas

haliliyas

tamer42

Destek Ekibi

haliliyas

tamer42

Destek Ekibi

haliliyas

haliliyas

haliliyas