Gelen kutusu bir süre sonra yalnızca mesajlardan oluşan bir liste değil, iş akışınızın nabzını tutan bir veri kaynağına dönüşür. Kim size en çok e-posta yazıyor? Hangi müşteri ya da tedarikçiyle yazışma hacmi daha yüksek? Bu soruların cevabı, dakikalar içinde çıkarabileceğiniz basit bir sayımla elinizin altında olabilir. Aşağıda, Outlook klasörlerinizi gezerek Gönderilmiş/Giden klasörlerini atlayan, sadece size gelen mailleri dikkate alıp gönderen bazında toplam mail sayısını hesaplayan ve sonucu Excel’e raporlayan pratik bir VBA çözümünü kurulumdan mantığına adım adım anlatıyorum.
Kodlar tam olarak ne işe yarıyor?
-
Outlook’taki tüm posta klasörlerini (alt klasörler dahil) tarayıp Gönderilmiş/Giden klasörlerini atlar.
-
Sadece size gönderilen mailleri sayar; sizin gönderdiğiniz mailleri analize dahil etmez.
-
Gönderen adresi veya adı bazında toplam mail sayısını hesaplar.
-
Sonuçları Excel’e aktarır ve en çok mail gönderenler üstte olacak şekilde azalan sıralar.
Çıktı, Excel’de iki sütundan oluşan yalın bir tablo: “Gönderen” ve “Toplam Mail Sayısı”.
Önkoşullar ve kurulum:
-
Kurumsal cihazlarda makrolar kapalı olabilir. Gerekirse IT politikanız dahilinde Güven Merkezi ayarlarında “Bildirim ile devre dışı bırak” seçeneğini kullanın.
-
Outlook’ta Alt + F11 ile VBA editörünü açın.
-
Insert → Module ile yeni bir modül oluşturun ve aşağıdaki kodu yapıştırın.
-
Makroyu F5 ile çalıştırın.
VBA Kodları:
Sub TumKlasorlerdekiMailleriExcelAktar()
Dim olNS As Outlook.NameSpace
Dim olStore As Outlook.store
Dim olRoot As Outlook.Folder
Dim dict As Object
Set olNS = Application.GetNamespace("MAPI")
Set olStore = olNS.Stores(1)
Set olRoot = olStore.GetRootFolder
Set dict = CreateObject("Scripting.Dictionary")
Call TumKlasorleriTara(olRoot, dict, olNS.currentUser.Address)
Dim arrKeys() As Variant
Dim arrValues() As Variant
Dim i As Long, j As Long
Dim tempKey As Variant, tempVal As Variant
arrKeys = dict.keys
arrValues = dict.Items
For i = LBound(arrValues) To UBound(arrValues) - 1
For j = i + 1 To UBound(arrValues)
If arrValues(j) > arrValues(i) Then
tempVal = arrValues(i)
arrValues(i) = arrValues(j)
arrValues(j) = tempVal
tempKey = arrKeys(i)
arrKeys(i) = arrKeys(j)
arrKeys(j) = tempKey
End If
Next j
Next i
Call AnaliziExcelAktar_Sirali(arrKeys, arrValues)
End Sub
Sub TumKlasorleriTara(ByVal klasor As Outlook.Folder, ByRef dict As Object, ByVal currentUser As String)
Dim olItem As Object
Dim altKlasor As Outlook.Folder
Dim gonderen As String
Dim i As Long
' Gönderilmiş klasörleri atla
If InStr(1, klasor.Name, "Gönderilmiş", vbTextCompare) > 0 _
Or InStr(1, klasor.Name, "Giden", vbTextCompare) > 0 Then
Exit Sub
End If
For i = 1 To klasor.Items.Count
Set olItem = klasor.Items(i)
If TypeName(olItem) = "MailItem" Then
If InStr(olItem.SenderEmailAddress, "/") > 0 Then
gonderen = olItem.SenderName
Else
gonderen = olItem.SenderEmailAddress
End If
' Şu an oturum açmış kullanıcının gönderdiği mailleri çıkar
If LCase(gonderen) <> LCase(currentUser) Then
If dict.Exists(gonderen) Then
dict(gonderen) = dict(gonderen) + 1
Else
dict(gonderen) = 1
End If
End If
End If
Next i
For Each altKlasor In klasor.Folders
Call TumKlasorleriTara(altKlasor, dict, currentUser)
Next
End Sub
Sub AnaliziExcelAktar_Sirali(ByVal arrKeys As Variant, ByVal arrValues As Variant)
Dim xlApp As Object
Dim xlWB As Object
Dim xlSheet As Object
Dim satir As Long
Dim i As Long
Set xlApp = CreateObject("Excel.Application")
xlApp.Visible = True
Set xlWB = xlApp.Workbooks.Add
Set xlSheet = xlWB.Sheets(1)
xlSheet.Cells(1, 1).Value = "Gönderen"
xlSheet.Cells(1, 2).Value = "Toplam Mail Sayısı"
satir = 2
For i = LBound(arrKeys) To UBound(arrKeys)
xlSheet.Cells(satir, 1).Value = arrKeys(i)
xlSheet.Cells(satir, 2).Value = arrValues(i)
satir = satir + 1
Next
xlSheet.Columns("A:B").AutoFit
MsgBox "Analiz tamamlandı. Excel dosyasında sonuçları görebilirsiniz.", vbInformation, "Tamamlandı"
End Sub
