Kota sayısı kadar maksimum tutarları bulma

[Recep İpek]

Merhaba

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.

  

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

4.000

 

[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.