Personel İlk 10 Listeleme

cimcoz

Altın Üye
Katılım
6 Ekim 2004
Mesajlar
273
Excel Vers. ve Dili
MS Office Plus 2016 & Mac OSX
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,
 

Ekli dosyalar

muygun

Özel Üye
Katılım
6 Temmuz 2004
Mesajlar
8,261
Excel Vers. ve Dili
Excel-2003 Türkçe
Merhaba;
Fonksiyonla bu iş biraz uğraştırır. Ama yapılamaz değil.
Eki inceleyin.
İyi çalışmalar.
 

Ekli dosyalar

Korhan Ayhan

Moderatör
Yönetici
Katılım
15 Mart 2005
Mesajlar
28,901
Excel Vers. ve Dili
OFFICE 2019 PRO TR
Alternatif;

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

C++:
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

Altın Üye
Katılım
6 Ekim 2004
Mesajlar
273
Excel Vers. ve Dili
MS Office Plus 2016 & Mac OSX
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

Altın Üye
Katılım
6 Ekim 2004
Mesajlar
273
Excel Vers. ve Dili
MS Office Plus 2016 & Mac OSX
Alternatif;

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

C++:
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.

221415
 
Üst