Merging 3 macros into 1

STEVENS3010

Board Regular
Joined
Feb 4, 2020
Messages
61
Office Version
  1. 365
  2. 2016
Platform
  1. Windows
Hi all,

I currently have 3 separate vba codes which I've put into a 4th code to run all 3 as the same time. The code takes quite a long time to run and I was wondering if somebody could help me amend the code so that there is only 1 rather than 3, hopefully making it more 'code friendly' and hopefully making it quicker to run?

I'm afraid I'm a newbie with regards to vba and the codes I have put together so far I've done so from searching previous messages. Any help would be greatly appreciated. I've pasted the codes I'm currently using below...

Code 1
VBA Code:
Sub getEmails()

    Dim olApp As Outlook.Application
    Dim olNS As Outlook.Namespace
    Dim olFldr As Outlook.MAPIFolder
    Dim olItem As Object
    Dim olMailItem As Outlook.MailItem
    Dim ws As Worksheet
    Dim iRow As Long
    Dim hdr As Variant
    
    Set ws = ThisWorkbook.Worksheets("Sheet1")
    
    Set olApp = New Outlook.Application
    Set olNS = olApp.GetNamespace("MAPI")
    
    Set olFldr = olNS.Folders("Dummy Folder")
    Set olFldr = olFldr.Folders("Inbox")
    Set olFldr = olFldr.Folders("Dummy Sub Folder")
    Set olFldr = olFldr.Folders("Work 1 Folder")
    
    ws.Cells.Clear
    iRow = 2
    
    Application.ScreenUpdating = False
    For Each olItem In olFldr.Items
        If olItem.Class = olMail Then
            Set olMailItem = olItem
            With olMailItem
                ws.Cells(iRow, "A") = .Subject
                ws.Cells(iRow, "B") = .ReceivedTime
                ws.Cells(iRow, "C") = .Categories
                iRow = iRow + 1
            End With
        End If
    Next olItem

    With ws
        hdr = Array("Subject", "ReceicedTime", "Categories")
        .Range("A1").Resize(, UBound(hdr)) = hdr
        .Columns.AutoFit
    End With
    Application.ScreenUpdating = False
End Sub

Code 2
VBA Code:
Sub getEmails2()

    Dim olApp As Outlook.Application
    Dim olNS As Outlook.Namespace
    Dim olFldr As Outlook.MAPIFolder
    Dim olItem As Object
    Dim olMailItem As Outlook.MailItem
    Dim ws As Worksheet
    Dim iRow As Long
    Dim hdr As Variant
    
    Set ws = ThisWorkbook.Worksheets("Sheet2")
    
    Set olApp = New Outlook.Application
    Set olNS = olApp.GetNamespace("MAPI")
    
    Set olFldr = olNS.Folders("Dummy Folder")
    Set olFldr = olFldr.Folders("Inbox")
    Set olFldr = olFldr.Folders(" Dummy Sub Folder")
    Set olFldr = olFldr.Folders("Work 2 Folder")
    
    ws.Cells.Clear
    iRow = 2
    
    Application.ScreenUpdating = False
    For Each olItem In olFldr.Items
        If olItem.Class = olMail Then
            Set olMailItem = olItem
            With olMailItem
                ws.Cells(iRow, "A") = .Subject
                ws.Cells(iRow, "B") = .ReceivedTime
                ws.Cells(iRow, "C") = .Categories
                iRow = iRow + 1
            End With
        End If
    Next olItem

    With ws
        hdr = Array("Subject", "ReceicedTime", "Categories")
        .Range("A1").Resize(, UBound(hdr)) = hdr
        .Columns.AutoFit
    End With
    Application.ScreenUpdating = False
End Sub

Code 3
VBA Code:
Sub getEmails3()

    Dim olApp As Outlook.Application
    Dim olNS As Outlook.Namespace
    Dim olFldr As Outlook.MAPIFolder
    Dim olItem As Object
    Dim olMailItem As Outlook.MailItem
    Dim ws As Worksheet
    Dim iRow As Long
    Dim hdr As Variant
    
    Set ws = ThisWorkbook.Worksheets("Sheet3")
    
    Set olApp = New Outlook.Application
    Set olNS = olApp.GetNamespace("MAPI")
    
    Set olFldr = olNS.Folders("Dummy Folder")
    Set olFldr = olFldr.Folders("Inbox")
    Set olFldr = olFldr.Folders("Dummy Sub Folder")
    Set olFldr = olFldr.Folders("Work 3 Folder")
    
    ws.Cells.Clear
    iRow = 2
    
    Application.ScreenUpdating = False
    For Each olItem In olFldr.Items
        If olItem.Class = olMail Then
            Set olMailItem = olItem
            With olMailItem
                ws.Cells(iRow, "A") = .Subject
                ws.Cells(iRow, "B") = .ReceivedTime
                ws.Cells(iRow, "C") = .Categories
                iRow = iRow + 1
            End With
        End If
    Next olItem

    With ws
        hdr = Array("Subject", "ReceicedTime", "Categories")
        .Range("A1").Resize(, UBound(hdr)) = hdr
        .Columns.AutoFit
    End With
    Application.ScreenUpdating = False
End Sub

Code 4
VBA Code:
Sub getemailsfromoutlook()
Call getEmails
Call getEmails2
Call getEmails3
End Sub
 

Excel Facts

Which lookup functions find a value equal or greater than the lookup value?
MATCH uses -1 to find larger value (lookup table must be sorted ZA). XLOOKUP uses 1 to find values greater and does not need to be sorted.

mart37

Well-known Member
Joined
Aug 4, 2017
Messages
1,091
Office Version
  1. 2016
Platform
  1. Windows
VBA Code:
Sub getemailsfromoutlook()
Call getEmails (wsName:="sheet1", FolderName:="Work 1 Folder"
Call getEmails (wsName:="sheet2", FolderName:="Work 2 Folder"
Call getEmails (wsName:="sheet3", FolderName:="Work 3 Folder"
End Sub

VBA Code:
Sub getEmails(wsName as String, FolderName as String)

    Dim olApp As Outlook.Application
    Dim olNS As Outlook.Namespace
    Dim olFldr As Outlook.MAPIFolder
    Dim olItem As Object
    Dim olMailItem As Outlook.MailItem
    Dim ws As Worksheet
    Dim iRow As Long
    Dim hdr As Variant
    
    Set ws = ThisWorkbook.Worksheets(wsName )
    
    Set olApp = New Outlook.Application
    Set olNS = olApp.GetNamespace("MAPI")
    
    Set olFldr = olNS.Folders("Dummy Folder")
    Set olFldr = olFldr.Folders(FolderName)
    
    ws.Cells.Clear
    iRow = 2
    
    Application.ScreenUpdating = False
    For Each olItem In olFldr.Items
        If olItem.Class = olMail Then
            Set olMailItem = olItem
            With olMailItem
                ws.Cells(iRow, "A") = .Subject
                ws.Cells(iRow, "B") = .ReceivedTime
                ws.Cells(iRow, "C") = .Categories
                iRow = iRow + 1
            End With
        End If
    Next olItem

    With ws
        hdr = Array("Subject", "ReceicedTime", "Categories")
        .Range("A1").Resize(, UBound(hdr)) = hdr
        .Columns.AutoFit
    End With
    Application.ScreenUpdating = False
End Sub
 

dmt32

Well-known Member
Joined
Jul 3, 2012
Messages
6,527
Office Version
  1. 2019
Platform
  1. Windows
Hi,
untested but you could try adding a loop to your code & see if that does what you want

something like following

VBA Code:
Sub getEmails()
    
    Dim olApp       As Outlook.Application
    Dim olNS        As Outlook.Namespace
    Dim olFldr      As Outlook.MAPIFolder
    Dim olItem      As Object
    Dim olMailItem  As Outlook.MailItem
    Dim ws          As Worksheet
    Dim iRow        As Long
    Dim i           As Integer
    Dim hdr         As Variant
    
    Application.ScreenUpdating = False
    For i = 1 To 3
        Set ws = ThisWorkbook.Worksheets("Sheet" & i)
        Set olApp = New Outlook.Application
        Set olNS = olApp.GetNamespace("MAPI")
        
        Set olFldr = olNS.Folders("Dummy Folder")
        Set olFldr = olFldr.Folders("Inbox")
        Set olFldr = olFldr.Folders("Dummy Sub Folder")
        Set olFldr = olFldr.Folders("Work " & i & " Folder")
        
        ws.UsedRange.Clear
        iRow = 2
        
        For Each olItem In olFldr.Items
            If olItem.Class = olMail Then
                Set olMailItem = olItem
                With olMailItem
                    ws.Cells(iRow, "A") = .Subject
                    ws.Cells(iRow, "B") = .ReceivedTime
                    ws.Cells(iRow, "C") = .Categories
                    iRow = iRow + 1
                End With
            End If
            Set olMailItem = Nothing
        Next olItem
        
        With ws
            hdr = Array("Subject", "ReceicedTime", "Categories")
            .Range("A1").Resize(, UBound(hdr)) = hdr
            .Columns.AutoFit
        End With
        
        'clear object variables
        Set ws = Nothing
        Set olApp = Nothing
        Set olNS = Nothing
        Set olFldr = Nothing
    Next i
    Application.ScreenUpdating = True
End Sub

Dave
 

STEVENS3010

Board Regular
Joined
Feb 4, 2020
Messages
61
Office Version
  1. 365
  2. 2016
Platform
  1. Windows
Hi,
untested but you could try adding a loop to your code & see if that does what you want

something like following

VBA Code:
Sub getEmails()
  
    Dim olApp       As Outlook.Application
    Dim olNS        As Outlook.Namespace
    Dim olFldr      As Outlook.MAPIFolder
    Dim olItem      As Object
    Dim olMailItem  As Outlook.MailItem
    Dim ws          As Worksheet
    Dim iRow        As Long
    Dim i           As Integer
    Dim hdr         As Variant
  
    Application.ScreenUpdating = False
    For i = 1 To 3
        Set ws = ThisWorkbook.Worksheets("Sheet" & i)
        Set olApp = New Outlook.Application
        Set olNS = olApp.GetNamespace("MAPI")
      
        Set olFldr = olNS.Folders("Dummy Folder")
        Set olFldr = olFldr.Folders("Inbox")
        Set olFldr = olFldr.Folders("Dummy Sub Folder")
        Set olFldr = olFldr.Folders("Work " & i & " Folder")
      
        ws.UsedRange.Clear
        iRow = 2
      
        For Each olItem In olFldr.Items
            If olItem.Class = olMail Then
                Set olMailItem = olItem
                With olMailItem
                    ws.Cells(iRow, "A") = .Subject
                    ws.Cells(iRow, "B") = .ReceivedTime
                    ws.Cells(iRow, "C") = .Categories
                    iRow = iRow + 1
                End With
            End If
            Set olMailItem = Nothing
        Next olItem
      
        With ws
            hdr = Array("Subject", "ReceicedTime", "Categories")
            .Range("A1").Resize(, UBound(hdr)) = hdr
            .Columns.AutoFit
        End With
      
        'clear object variables
        Set ws = Nothing
        Set olApp = Nothing
        Set olNS = Nothing
        Set olFldr = Nothing
    Next i
    Application.ScreenUpdating = True
End Sub

Dave
Hi Dave, thanks for this. I’ve not tested it yet but I think I’ve spotted a potential problem. The folder names ‘Work 1’ ‘Work 2’ and ‘Work 3’ are dummy names I’ve used for simplicity.

If for example, the folder names were ‘invoices’ ‘payments’ and ‘backlog’ would the above code need to be amended? Cheers
 

dmt32

Well-known Member
Joined
Jul 3, 2012
Messages
6,527
Office Version
  1. 2019
Platform
  1. Windows

ADVERTISEMENT

Hi Dave, thanks for this. I’ve not tested it yet but I think I’ve spotted a potential problem. The folder names ‘Work 1’ ‘Work 2’ and ‘Work 3’ are dummy names I’ve used for simplicity.

If for example, the folder names were ‘invoices’ ‘payments’ and ‘backlog’ would the above code need to be amended? Cheers
Hi,
just amend the line to use the Choose function

VBA Code:
Set olFldr = olFldr.Folders(Choose(i, "invoices", "payments", "backlog"))

With each iteration of the for next loop, this will select the next required folder in the list

Dave
 

STEVENS3010

Board Regular
Joined
Feb 4, 2020
Messages
61
Office Version
  1. 365
  2. 2016
Platform
  1. Windows
Thanks Dave, that seems to have done the trick.
 

Watch MrExcel Video

Forum statistics

Threads
1,130,317
Messages
5,641,491
Members
417,212
Latest member
rsturbox

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Top