Personel İlk 10 Listeleme

[cimcoz]

Merhaba,

Ekteki dosyama göre;

AJ sütunundaki personel listesi

AK-AN arasında da şehirlere göre satış adetleri bulunuyor. (listem çok satırlı o yüzden ufak örnek yolluyorum)

BA sütunundan itibaren örnekteki gibi, en çok satış yapan personel adını ve toplam adetlerini yanlarına yazdırmak istiyorum. (Adetleri aynı olanlar da alfabetik olarak listelenebilir)

Her şehire ait TOP 10 sıralaması gibi düşünülebilir.

Gerekli formül konusunda yardımlarını rica ederim.


Saygılarımla,

 

[muygun]

Merhaba;
Fonksiyonla bu iş biraz uğraştırır. Ama yapılamaz değil.
Eki inceleyin.
İyi çalışmalar.

 

[Korhan Ayhan]

Alternatif;

ADO yöntemi kullanılmıştır. (Mac işletim sisteminde çalışmayabilir.)

Option Explicit

Sub Top_10_Listesi()
    Dim Baglanti As Object, Kayit_Seti As Object, Sorgu As String, Zaman As Double
    Dim S1 As Worksheet, Satir As Byte, Sutun As Byte, X As Byte, Say As Long
    
    Zaman = Timer
    
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    
    Set Baglanti = CreateObject("AdoDb.Connection")
    Set Kayit_Seti = CreateObject("AdoDb.Recordset")
    Set S1 = Sheets("Sheet1")
    
    S1.Range("BA2:BD" & S1.Rows.Count).ClearContents
    
    Baglanti.Open "Provider=Microsoft.Ace.OleDb.12.0;Data Source=" & _
    ThisWorkbook.FullName & ";Extended Properties=""Excel 12.0;Hdr=No"""
    
    Sutun = 53
    
    For X = 2 To 5
        Satir = 2
        Say = 0
        
        Sorgu = "Select Top 10 F1 & ' ' & F" & X & " From [" & S1.Name & "$AJ2:AN] Where F1 Is Not Null Order By F" & X & " Desc"
        
        Kayit_Seti.Open Sorgu, Baglanti, 1, 1
        
        If Kayit_Seti.RecordCount > 0 Then
            Kayit_Seti.MoveFirst
            Do While Not Kayit_Seti.EOF
                Say = Say + 1
                S1.Cells(Satir, Sutun) = Kayit_Seti(0)
                Satir = Satir + 1
                Kayit_Seti.MoveNext
                If Say = 10 Then Exit Do
            Loop
        End If
        Sutun = Sutun + 1
        If Kayit_Seti.State <> 0 Then Kayit_Seti.Close
    Next
    
    S1.Columns.AutoFit
    
    If Kayit_Seti.State <> 0 Then Kayit_Seti.Close
    If Baglanti.State <> 0 Then Baglanti.Close
    
    Set Kayit_Seti = Nothing
    Set Baglanti = Nothing
    Set S1 = Nothing
            
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
    
    MsgBox "İşleminiz tamamlanmıştır." & Chr(10) & Chr(10) & _
           "İşlem süresi ; " & Format(Timer - Zaman, "0.00") & " Saniye", vbInformation
End Sub

 

[cimcoz]

Merhaba;
Fonksiyonla bu iş biraz uğraştırır. Ama yapılamaz değil.
Eki inceleyin.
İyi çalışmalar.

Sayın muygun,

Elleriniz sağlık, ihtiyacımdan da fazlası olmuş .
Değerli zamanınızı ayırdığınız için çok teşekkür ederim.

Saygılarımla,,

 

[cimcoz]

Alternatif;

ADO yöntemi kullanılmıştır. (Mac işletim sisteminde çalışmayabilir.)

Option Explicit

Sub Top_10_Listesi()
    Dim Baglanti As Object, Kayit_Seti As Object, Sorgu As String, Zaman As Double
    Dim S1 As Worksheet, Satir As Byte, Sutun As Byte, X As Byte, Say As Long
   
    Zaman = Timer
   
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
   
    Set Baglanti = CreateObject("AdoDb.Connection")
    Set Kayit_Seti = CreateObject("AdoDb.Recordset")
    Set S1 = Sheets("Sheet1")
   
    S1.Range("BA2:BD" & S1.Rows.Count).ClearContents
   
    Baglanti.Open "Provider=Microsoft.Ace.OleDb.12.0;Data Source=" & _
    ThisWorkbook.FullName & ";Extended Properties=""Excel 12.0;Hdr=No"""
   
    Sutun = 53
   
    For X = 2 To 5
        Satir = 2
        Say = 0
       
        Sorgu = "Select Top 10 F1 & ' ' & F" & X & " From [" & S1.Name & "$AJ2:AN] Where F1 Is Not Null Order By F" & X & " Desc"
       
        Kayit_Seti.Open Sorgu, Baglanti, 1, 1
       
        If Kayit_Seti.RecordCount > 0 Then
            Kayit_Seti.MoveFirst
            Do While Not Kayit_Seti.EOF
                Say = Say + 1
                S1.Cells(Satir, Sutun) = Kayit_Seti(0)
                Satir = Satir + 1
                Kayit_Seti.MoveNext
                If Say = 10 Then Exit Do
            Loop
        End If
        Sutun = Sutun + 1
        If Kayit_Seti.State <> 0 Then Kayit_Seti.Close
    Next
   
    S1.Columns.AutoFit
   
    If Kayit_Seti.State <> 0 Then Kayit_Seti.Close
    If Baglanti.State <> 0 Then Baglanti.Close
   
    Set Kayit_Seti = Nothing
    Set Baglanti = Nothing
    Set S1 = Nothing
           
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
   
    MsgBox "İşleminiz tamamlanmıştır." & Chr(10) & Chr(10) & _
           "İşlem süresi ; " & Format(Timer - Zaman, "0.00") & " Saniye", vbInformation
End Sub

Dediğiniz gibi component/lisans hatası veriyor.