Merging 3 macros into 1

S

STEVENS3010

Board Regular
Joined
Feb 4, 2020
Messages
87
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

Select all contiguous cells
Pressing Ctrl+* (asterisk) will select the "current region" - all contiguous cells in all directions.
Sort by date Sort by votes
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
 
Upvote 0
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
 
Upvote 0
dmt32 said:
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
Click to expand...
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
 
Upvote 0
STEVENS3010 said:
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
Click to expand...
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
 
Upvote 0
You must log in or register to reply here.

Similar threads

S
  • Question
Export Attachment from outlook to excel cells
Replies
1
Views
638
Zaifee
Z
V
  • Question
Email Check
Replies
1
Views
243
vmjan02
V
L
  • Question
VBA Email extract problem
Replies
0
Views
348
Liverlee
L
J
  • Question
Parse HTML table or extract Outlook body items to excel sheet
Replies
2
Views
217
Jaffirahamed
J
A
  • Solved
Excel Macro to get Email Subject of mails received today from outlook
Replies
9
Views
3K
atuljadhavnetafim
A

Forum statistics

Threads
1,214,812
Messages
6,121,702
Members
449,048
Latest member
81jamesacct

Share this page

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
Back
Top