Top 5 Müşteriyi Bulma

S

Sunburcu

Katılım
5 Kasım 2022
Mesajlar
11
Excel Vers. ve Dili
Excel
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
 
P

pitchoute

Katılım
11 Temmuz 2024
Mesajlar
281
Excel Vers. ve Dili
Excel 2021 Türkçe
Yedek aldıktan sonra deneyip sonucu paylaşabilir misiniz;

Kod: 
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
 
Korhan Ayhan

Korhan Ayhan

Administrator
Yönetici
Admin
Katılım
15 Mart 2005
Mesajlar
42,882
Excel Vers. ve Dili
Microsoft 365 Tr-En 64 Bit
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 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.
 
S

Sunburcu

Katılım
5 Kasım 2022
Mesajlar
11
Excel Vers. ve Dili
Excel
pitchoute' Alıntı:
Yedek aldıktan sonra deneyip sonucu paylaşabilir misiniz;

Kod: 
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
Genişletmek için tıkla ...
Merhabalar;
Kod olarak değil ama formül ile çözebileceğimiz bir yöntem yok mu acaba
 
S

Sunburcu

Katılım
5 Kasım 2022
Mesajlar
11
Excel Vers. ve Dili
Excel
Korhan Ayhan' Alıntı:
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 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.
Genişletmek için tıkla ...
Merhabalar;
365 kullanmıyorum. Excel ile aktaramıyorum buraya maalesef.Ya da nasıl aktarıldığını bilmiyor olabilirim.
 
Korhan Ayhan

Korhan Ayhan

Administrator
Yönetici
Admin
Katılım
15 Mart 2005
Mesajlar
42,882
Excel Vers. ve Dili
Microsoft 365 Tr-En 64 Bit
Dosya paylaşmak için altın üye olabilirsiniz. Ya da ücretsiz olarak dosya yükleme sitelerini kullanarak dosya linkini forumda paylaşabilirsiniz.
 
Korhan Ayhan

Korhan Ayhan

Administrator
Yönetici
Admin
Katılım
15 Mart 2005
Mesajlar
42,882
Excel Vers. ve Dili
Microsoft 365 Tr-En 64 Bit
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.
 
Cevap yazmak için giriş yap yada kayıt ol.
Üst