Converting email count vba to Excel table

[hamezz123]

I am trying to convert this VBA which counts the catagories in outlook and gives it back as a text box but i want to transfer this data to an excel table so it is useable as i have to do it manually at the moment

Sub CategoriesEmails()

Dim oFolder As MAPIFolder
Dim oDict As Object
Dim sStartDate As String
Dim sEndDate As String
Dim oItems As Outlook.Items
Dim sStr As String
Dim sMsg As String


On Error Resume Next
Set oFolder = Application.ActiveExplorer.CurrentFolder

Set oDict = CreateObject("Scripting.Dictionary")

sStartDate = "08/20/2009" 'InputBox("Type the start date (format MM/DD/YYYY)")
sEndDate = "02/09/2020" 'InputBox("Type the end date (format MM/DD/YYYY)")

Set oItems = oFolder.Items.Restrict("[Received] >= '" & sStartDate & "' And [Received] <= '" & sEndDate & "'")
oItems.SetColumns ("Categories")

For Each aitem In oItems
sStr = aitem.Categories
If Not oDict.Exists(sStr) Then
oDict(sStr) = 0
End If
oDict(sStr) = CLng(oDict(sStr)) + 1
Next aitem

sMsg = ""
For Each aKey In oDict.Keys
sMsg = sMsg & aKey & ": " & oDict(aKey) & vbCrLf
Next
MsgBox sMsg

Set oFolder = Nothing

End Sub

 

[Rijnsent]

Hi Hamezz,
replace the sMsg block with something like this:

Set Sht = Worksheets("Sheet1")
Rw = 2
For Each aKey In oDict.Keys
    Sht.Range("A" & Rw).Value = aKey
    Sht.Range("B" & Rw).Value = oDict(aKey)
Next

Cheers,
Koen

 

[hamezz123]

I have gotten to this stage so far I see that excel is doing something but i don't know what and cant find it
an Excel sheet appears and then disappears and i cant see any location for it

 Sub CategoriesEmails()

    Dim oFolder As MAPIFolder
    Dim oDict As Object
    Dim sStartDate As String
    Dim sEndDate As String
    Dim oItems As Outlook.Items
    Dim sStr As String
    Dim sMsg As String
    Dim strFldr As String
    Dim OutMail As Object
    Dim xlApp As Object

    On Error Resume Next
    Set oFolder = Application.ActiveExplorer.CurrentFolder
    
    oItems.SetColumns ("Categories")
    
    Set oDict = CreateObject("Scripting.Dictionary")

    sStartDate = "08/20/2019"
    sEndDate = "02/09/2020"
    
    Set oItems = oFolder.Items.Restrict("[Received] >= '" & sStartDate & "' And [Received] <= '" & sEndDate & "'")
    oItems.SetColumns ("Categories")

    For Each aItem In oItems
    sStr = aItem.Categories
    If Not oDict.Exists(sStr) Then
    oDict(sStr) = 0
    End If
    oDict(sStr) = CLng(oDict(sStr)) + 1
    Next aItem

    sMsg = ""
    i = 0

    strFldr = "C:\"
    Set xlApp = CreateObject("Excel.Application")
    xlApp.Application.Visible = True
    xlApp.Workbooks.Open strFldr & "TestingCatagories.xlsx"
    xlApp.Sheets("Sheet1").Select
    For Each aKey In oDict.Keys
    xlApp.Range("A1").Offset(i, 0).Value = sMsg & aKey
    xlApp.Range("B1").Offset(i, 0).Value = oDict(aKey) & vbCrLf
    i = i + 1
    Next
    xlApp.Save

    Set oFolder = Nothing

     End Sub

Any idea how to fix?

 

[Rijnsent]

The answer is in your code:

strFldr = "C:\"  'the location where the result will be stored
xlApp.Workbooks.Open strFldr & "TestingCatagories.xlsx" 'This is the location and the file name
xlApp.Save 'This saves the file

Cheers,
Koen

 

[hamezz123]

So should this work or am i missing spots? excel appears and then disappears and nothing is saved?

 

[Rijnsent]

There should be a result in C:\TestingCatagories.xlsx . If not, try changing the directory to a location you can access (C:\ might be protected), that could help. Try e.g. this updated code:

    strFldr = "C:\"
    Set xlApp = CreateObject("Excel.Application")
    xlApp.Application.Visible = True
    'xlApp.Workbooks.Open strFldr & "TestingCatagories.xlsx"  -> this probably fails, as the file doesn't exist, try creating a new file instead

    Set xlWB = xlApp.Workbooks.Add
    Set xlWS = xlWB.Worksheets(1)  'references to the first worksheet, name doesn't matter
    'xlApp.Sheets("Sheet1").Select -> not needed to select
    For Each aKey In oDict.Keys
        xlWS.Range("A1").Offset(i, 0).Value = sMsg & aKey
        xlWS.Range("B1").Offset(i, 0).Value = oDict(aKey) & vbCrLf
        i = i + 1
    Next
    xlWB.SaveAs fullFilePath, AccessMode:=xlExclusive,ConflictResolution:=Excel.XlSaveConflictResolution.xlLocalSessionChanges    'This might fail if a file with that name is present, not tested
    'xlWB.Close (True)
    'File should stay open...

 

[hamezz123]

Awesome Thank you ill play with it some more