Kota sayısı kadar maksimum tutarları bulma

[Recep İpek]

[TR][TD]
Merhaba
[/TD][/TR]
[TR][TD]
Aşağıdaki gibi bir tabloda sicil bazında yanında yazan kota sayısı kadar maksimum tutarları nasıl tespit edebilirim? Kota sayısı kadar veri yok ise tümünü dikkate alınacak.
[/TD]
[TD]

[/TD]
[TD]

[/TD][/TR]
[TR][TD]

Tablo
İsim Kota Tutar
ALİ 2 1.000
AHMET 3 1.000
AHMET 3 2.000
MEHMET 2 1.000
MEHMET 2 2.000
MEHMET 2 3.000
ÖMER 2 1.000
ÖMER 2 2.000
ÖMER 2 3.000
TARIK 2 3.000
TARIK 2 1.000
TARIK 2 3.000

Sonuç
İsim Kota Tutar
ALİ 2 1.000
AHMET 3 2.000
AHMET 3 1.000
MEHMET 2 3.000
MEHMET 2 2.000
ÖMER 2 3.000
ÖMER 2 2.000
TARIK 2 3.000
TARIK 2 3.000
[/TD]
[TD]
4.000
[/TD][/TR]

 

[Haluk]

ADO kullanarak hazırlanmış bir alternatif ektedir.....

.

 

[Korhan Ayhan]

Alternatif;

Dictionary ile çözüm..

 

[Haluk]

Sanırım "Altın Üye" olmadığınız için eklenen dosyaları indirip, deneyemiyorsunuz.


Dosyadaki sayfanın görüntüsü aşağıdaki gibidir, veriler sizin 1. mesajınızdan alındı....

Not: VBA projenize, Tools >> References menüsünden "Microsoft ActiveX Data Objects 2.8 Library" eklenmelidir.

--------------------------------
|A  |   B        |  C   |   D  |
|---|------------|------|------|
|1  | İsim       | Kota | Tutar|
|---|------------|------|------|
|2  | ALİ        | 2    | 1000 |
|---|------------|------|------|
|3  | AHMET      | 3    | 1000 |
|---|------------|------|------|
|4  | AHMET      | 3    | 2000 |
|---|------------|------|------|
|5  | MEHMET     | 2    | 1000 |
|---|------------|------|------|
|6  | MEHMET     | 2    | 2000 |
|---|------------|------|------|
|7  | MEHMET     | 2    | 3000 |
|---|------------|------|------|
|8  | ÖMER       | 2    | 1000 |
|---|------------|------|------|
|9  | ÖMER       | 2    | 2000 |
|---|------------|------|------|
|10 | ÖMER       | 2    | 3000 |
|---|------------|------|------|
|11 | TARIK      | 2    | 3000 |
|---|------------|------|------|
|12 | TARIK      | 2    | 1000 |
|---|------------|------|------|
|13 | TARIK      | 2    | 3000 |
|---|------------|-------------|

Yukarıda belirtildiği gibi sayfanızı düzeledikten sonra kullanacağınız kod ise, aşağıda verilmiştir;

Sub Test()
'   Haluk - 29/11/2020
'   sa4truss@gmail.com
'
    Dim objADO As ADODB.Connection
    Dim objRS As ADODB.Recordset
    Dim strFile As String
    Dim strSQL As String
 
    Range("I1:K" & Rows.Count) = ""
 
    Set objADO = New ADODB.Connection
    Set objRS = New ADODB.Recordset
 
    strFile = ThisWorkbook.FullName
 
    With objADO
        If Val(Application.Version) < 14 Then
            .Provider = "Microsoft.Jet.OLEDB.4.0"
            .Properties("Extended Properties") = "Excel 8.0; HDR=Yes;IMEX=1;"
        Else
            .Provider = "Microsoft.Ace.OLEDB.12.0"
            .Properties("Extended Properties") = "Excel 12.0; HDR=Yes;IMEX=1;"
        End If
       .ConnectionString = strFile
       .Open
    End With
 
    strSQL = "Select distinct [İsim], [Kota] from [Sheet1$]"
 
    With objRS
        .CursorType = adOpenStatic
        .CursorLocation = adUseClient
        .LockType = adLockBatchOptimistic
        .ActiveConnection = objADO
        .Source = strSQL
        .Open
    End With
 
    countData = objRS.RecordCount
 
    ReDim arrData(0 To countData - 1, 0 To countData - 1)
    arrData = objRS.GetRows(objRS.RecordCount, , Array("İsim", "Kota"))
    objRS.Close
 
    Range("I1:K1") = Array("İsim", "Kota", "Tutar")
 
    For j = 0 To countData - 1
        strSQL = "Select top " & arrData(1, j) & " [İsim], [Kota], [Tutar] from [Sheet1$] where [İsim]='" & arrData(0, j) & "' order by [Tutar] desc"
        With objRS
           .CursorType = adOpenStatic
           .CursorLocation = adUseClient
           .LockType = adLockBatchOptimistic
           .ActiveConnection = objADO
           .Source = strSQL
           .Open
        End With
     
        NoI = Range("I" & Rows.Count).End(xlUp).Row + 1
     
        Sheets("Sheet1").Range("I" & NoI).CopyFromRecordset objRS
     
        If objRS.State = adStateOpen Then objRS.Close
    Next
 
    If objADO.State = adStateOpen Then objADO.Close
 
    Set objRS = Nothing
    Set objADO = Nothing
End Sub

.

 

[Recep İpek]

Her iki üstadımıza teşekkürler. Çözümleriniz birbirinden müthiş.

 

[Korhan Ayhan]

@Haluk bey Recep bey zaten uzman kadrosundadır. Dosyalara erişimi olması gerekir.

 

[Haluk]

@Haluk bey Recep bey zaten uzman kadrosundadır. Dosyalara erişimi olması gerekir.

Hmmm.... o kısmını kaçırmışım. Herhangi bir cevap gelmeyince, dosyaları indiremediğini sanmıştım.

.

 

[Recep İpek]

Ben yine de her ihtimale karşı Altın Üye oldum. Formuma destek her zaman önceliğimizdir.