Top 5 Müşteriyi Bulma

[Sunburcu]

Merhabalar;
Elimde birden çok müşterinin olduğu, varış il, varış ilçe ve ve oralara sevk edilen araç sayılarının olduğu bir rapor var.
Her müşterinin ayrı ayrı top 5 ini yapmam gerekiyor. En çok araç çıkışı yaptığı yere göre.
Uzun bir liste olduğu için formül kullanmam gerekiyor. Aşağıdaki görselde Top 5 olarak örnek olarak yapmak istediğimi gösterdim.
Şimdiden destekleriniz için teşekkürler

 

[Korhan Ayhan]

Merhaba,

Linki inceleyerek profilinizi güncellemenizi rica ederim.

Bilgi - Profillerde yazan "Ofis Sürümü ve Dili" bilgisi hakkında

Merhaba Değerli Forum Üyeleri, Belki dikkatinizi çekmiştir. Son zamanlarda birçok üyemize açtıkları başlıklarda cevap vermeden önce "Kullandığınız ofis sürümü ve dili nedir?" şeklinde mesaj yazıyorum. Bu alanın kullanım amacı sizlere verilecek cevaplar için önem arz etmektedir. Bu sebeple bu...

www.excel.web.tr

Eğer Ofis 365 sürümünü kullanıyorsanız çözüm yerleşik işlevlerle yapılabilir görünüyor.

Örnek dosya paylaşabilirseniz çözüm için uğraşmak isteyenlere kolaylık olacaktır.

 

[Sunburcu]

Yedek aldıktan sonra deneyip sonucu paylaşabilir misiniz;

Sub Top5MusteriRaporu()
    Dim ws As Worksheet
    Dim lastRow As Long
    Dim musteriList As Object
    Dim musteri As Variant
    Dim i As Long, j As Long, k As Long
    Dim outputRow As Long
    Dim tempArr() As Variant
    Dim tempCount As Long
    Dim outputSheet As Worksheet
   
    On Error Resume Next
    Set ws = ActiveSheet
    lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
   
    Set musteriList = CreateObject("Scripting.Dictionary")
   
    For i = 2 To lastRow
        If Not musteriList.exists(ws.Cells(i, 1).Value) Then
            musteriList.Add ws.Cells(i, 1).Value, 1
        End If
    Next i
   
    On Error Resume Next
    Set outputSheet = Worksheets("Top5Rapor")
    If outputSheet Is Nothing Then
        Set outputSheet = Worksheets.Add(After:=Worksheets(Worksheets.Count))
        outputSheet.Name = "Top5Rapor"
    Else
        outputSheet.Cells.Clear
    End If
    On Error GoTo 0
   
    outputSheet.Cells(1, 1).Value = "MÜŞTERİ"
    outputSheet.Cells(1, 2).Value = "VARIŞ İL"
    outputSheet.Cells(1, 3).Value = "VARIŞ İLÇE"
    outputSheet.Cells(1, 4).Value = "ARAÇ SAYISI"
    outputSheet.Range("A1:D1").Font.Bold = True
    outputSheet.Range("A1:D1").HorizontalAlignment = xlCenter
    outputRow = 2
   
    For Each musteri In musteriList.Keys
        Dim locationDict As Object
        Set locationDict = CreateObject("Scripting.Dictionary")
       
        For i = 2 To lastRow
            If ws.Cells(i, 1).Value = musteri Then
                Dim key As String
                Dim ilce As String, il As String, aracSayisi As Long
                il = ws.Cells(i, 2).Value
                ilce = ws.Cells(i, 3).Value
                key = il & "|" & ilce
                aracSayisi = ws.Cells(i, 4).Value
               
                If locationDict.exists(key) Then
                    locationDict(key) = locationDict(key) + aracSayisi
                Else
                    locationDict.Add key, aracSayisi
                End If
            End If
        Next i
       
        tempCount = locationDict.Count
        If tempCount > 0 Then
            ReDim tempArr(1 To tempCount, 1 To 3)
            j = 1
            For Each key In locationDict.Keys
                Dim parts As Variant
                parts = Split(key, "|")
               
                tempArr(j, 1) = parts(0)
                tempArr(j, 2) = parts(1)
                tempArr(j, 3) = locationDict(key)
                j = j + 1
            Next key
           
            For j = 1 To tempCount - 1
                For k = j + 1 To tempCount
                    If tempArr(j, 3) < tempArr(k, 3) Then
                        Dim tempIl As String, tempIlce As String, tempSayi As Long
                        tempIl = tempArr(j, 1)
                        tempIlce = tempArr(j, 2)
                        tempSayi = tempArr(j, 3)
                        tempArr(j, 1) = tempArr(k, 1)
                        tempArr(j, 2) = tempArr(k, 2)
                        tempArr(j, 3) = tempArr(k, 3)
                        tempArr(k, 1) = tempIl
                        tempArr(k, 2) = tempIlce
                        tempArr(k, 3) = tempSayi
                    End If
                Next k
            Next j
           
            Dim topCount As Integer
            topCount = Application.WorksheetFunction.Min(5, tempCount)
           
            For j = 1 To topCount
                outputSheet.Cells(outputRow, 1).Value = musteri
                outputSheet.Cells(outputRow, 2).Value = tempArr(j, 1)
                outputSheet.Cells(outputRow, 3).Value = tempArr(j, 2)
                outputSheet.Cells(outputRow, 4).Value = tempArr(j, 3)
                outputRow = outputRow + 1
            Next j
        End If
    Next musteri
   
    outputSheet.Columns("A:D").AutoFit
   
    outputSheet.Activate
    outputSheet.Range("A1").Select
   
    MsgBox "Top 5 müşteri raporu oluşturuldu!", vbInformation
End Sub

Merhabalar;
Kod olarak değil ama formül ile çözebileceğimiz bir yöntem yok mu acaba

 

[Sunburcu]

Merhaba,

Linki inceleyerek profilinizi güncellemenizi rica ederim.

Bilgi - Profillerde yazan "Ofis Sürümü ve Dili" bilgisi hakkında

Merhaba Değerli Forum Üyeleri, Belki dikkatinizi çekmiştir. Son zamanlarda birçok üyemize açtıkları başlıklarda cevap vermeden önce "Kullandığınız ofis sürümü ve dili nedir?" şeklinde mesaj yazıyorum. Bu alanın kullanım amacı sizlere verilecek cevaplar için önem arz etmektedir. Bu sebeple bu...

www.excel.web.tr

Eğer Ofis 365 sürümünü kullanıyorsanız çözüm yerleşik işlevlerle yapılabilir görünüyor.

Örnek dosya paylaşabilirseniz çözüm için uğraşmak isteyenlere kolaylık olacaktır.

Merhabalar;
365 kullanmıyorum. Excel ile aktaramıyorum buraya maalesef.Ya da nasıl aktarıldığını bilmiyor olabilirim.

 

[Korhan Ayhan]

Dosya paylaşmak için altın üye olabilirsiniz. Ya da ücretsiz olarak dosya yükleme sitelerini kullanarak dosya linkini forumda paylaşabilirsiniz.

 

[Sunburcu]

Dosya paylaşmak için altın üye olabilirsiniz. Ya da ücretsiz olarak dosya yükleme sitelerini kullanarak dosya linkini forumda paylaşabilirsiniz.

https://www.mediafire.com/file/1kiejumfec8p0eg/Excel+Çalışma.xlsx/file

 

[Korhan Ayhan]

Aşağıdaki gibi görünen profilinizi de lütfen güncelleyiniz.

Excel Vers. ve Dili Excel

Paylaştığınız linkten dosyaya erişemedim. Kontrol etmenizde fayda var.