Hello,

I've been using VBA for several months now. I realize that most of what I write is possibly not the most efficient solution. I'm seeking ways to improve my code. Are there common tricks to be aware of? I'm attaching sample code I'm using in Outlook as a learning example.

Thanks!

Sub CopyInfoToExcel(olItem As MailItem)
    
    Dim olApp As Outlook.Application
    Dim objNS As Outlook.NameSpace
    Dim olFolder As Outlook.MAPIFolder
    Dim xlApp As Object
    Dim xlWB As Object
    Dim xlSheet As Object
    Dim xlSheet2 As Object
    Dim tiFolder As Folder
    Dim txtContact As String, txtCompany As String, txtSubject As String ', txtEmail As String
    Dim sText As String
    Dim sAddr As String
    Dim vAddr As Variant
    Dim vItem As Variant
    Dim rCount As Long
    Dim bXStarted As Boolean
    Dim start As Date
    Dim Finish As Date
    Dim kItem As String
    Dim quoteID As Long
    Dim kNumber As String
    Dim wbTEST As Object
    Dim T0 As Long
    Dim objOwner As Outlook.Recipient
    Dim Rng As Range
    Dim NxtQuote As Long
    Dim Pass As String
    Dim olkSnd As Outlook.AddressEntry, olkExu As Outlook.ExchangeUser
    Dim olkMsg As Outlook.MailItem
    
    Pass = "12345"
    
    start = Now
    
    Excel.Application.DisplayAlerts = False
    Set xlWB = Excel.Application.Workbooks.Open("\\uswifs05\Matisse\Source\Prod\QuoteView\Data\KPS Sales Quote Index.xlsm")
    
    If xlWB.ReadOnly Then
        
        Do Until Not xlWB.ReadOnly
            
            xlWB.Close savechanges:=False
            
            Do Until Now > start + TimeValue("0:00:05")
                
            Loop
            
            Debug.Print "If not closed, close the original ReadWrite version now."
            
            Set xlWB = Excel.Application.Workbooks.Open("\\uswifs05\Matisse\Source\Prod\QuoteView\Data\KPS Sales Quote Index.xlsm")
            start = Now
            
        Loop
        
    End If
    
    Debug.Print "Read write version should be ready now."
    
    Set olApp = Outlook.Application
    Set xlApp = Excel.Application
    Set xlSheet = xlWB.Sheets("DATA")
    Set xlSheet2 = xlWB.Sheets("CustomerContacts")
    Set objNS = olApp.GetNamespace("MAPI")
    Set objOwner = objNS.CreateRecipient("appengineer@kohler.com")
    objOwner.Resolve
    Set olFolder = objNS.GetSharedDefaultFolder(objOwner, olFolderInbox)
    Set tiFolder = olFolder.Folders("Information")
    
    Set olkSnd = olItem.Sender
    If olkSnd.AddressEntryUserType = olExchangeUserAddressEntry Then
        Set olkExu = olkSnd.GetExchangeUser
        GetSMTPAddress = olkExu.PrimarySmtpAddress
    Else: GetSMTPAddress = olItem.SenderEmailAddress
    End If
    
    'txtEmail = Trim(olItem.Body)
    
'Find the next empty line of the worksheet
    rCount = xlSheet.Range("C" & xlSheet.Rows.Count).End(-4162).Row + 1
    
'Create K number
    xlSheet.UnProtect (Pass)
    
'On Error GoTo ERRORHANDLER
    
    With xlSheet
        
        Set Rng = .Range("C:C")
        
        If Format(Date, "YYYY") = 2016 Then
            If xlApp.WorksheetFunction.Max(Rng) >= 1600000 Then
                NxtQuote = xlApp.WorksheetFunction.Max(Rng) + 1
                Else: NxtQuote = 1600000
            End If
        ElseIf Format(Date, "YYYY") = 2017 Then
            If xlApp.WorksheetFunction.Max(Rng) >= 1700000 Then
                NxtQuote = xlApp.WorksheetFunction.Max(Rng) + 1
                Else: NxtQuote = 1700000
            End If
        ElseIf Format(Date, "YYYY") = 2018 Then
            If xlApp.WorksheetFunction.Max(Rng) >= 1800000 Then
                NxtQuote = xlApp.WorksheetFunction.Max(Rng) + 1
                Else: NxtQuote = 1800000
            End If
        ElseIf Format(Date, "YYYY") = 2019 Then
            If xlApp.WorksheetFunction.Max(Rng) >= 1900000 Then
                NxtQuote = xlApp.WorksheetFunction.Max(Rng) + 1
                Else: NxtQuote = 1900000
            End If
        ElseIf Format(Date, "YYYY") = 2020 Then
            If xlApp.WorksheetFunction.Max(Rng) >= 2000000 Then
                NxtQuote = xlApp.WorksheetFunction.Max(Rng) + 1
                Else: NxtQuote = 2000000
            End If
        End If
    End With
    
'quoteID = NxtQuote 'Project ID
    
    kNumber = "K" & NxtQuote & "-" & "TI" & "-1"
    
'Add K number to subject line
    kItem = kNumber
    txtSubject = olItem.Subject
    olItem.Subject = kItem & "  |  " & txtSubject
    
    xlSheet2.Range("G" & 2) = GetSMTPAddress 'Sender email address to be processed for Contact name
    xlSheet2.Range("I" & 2) = GetSMTPAddress 'Sender email address to be processed for Company
    start = Now
    Do Until Now > start + TimeValue("0:00:01")
    Loop
    txtContact = xlSheet2.Range("G" & 4) 'Contact name gets assigned variable
    txtCompany = xlSheet2.Range("I" & 4) 'Company gets assigned variable
    xlSheet.Range("L" & rCount) = txtContact 'Contact Name
    xlSheet.Range("K" & rCount) = txtCompany 'Company
    xlSheet.Range("D" & rCount) = "TI" 'Category ID (TI, TA, SG, LG)
    xlSheet.Range("N" & rCount) = GetSMTPAddress 'email
    xlSheet.Range("E" & rCount) = "1" 'Revision
    xlSheet.Range("C" & rCount) = NxtQuote 'Quote ID
    xlSheet.Range("F" & rCount) = "TIG" 'Queue Type (TAG, Large Gas, Switchgear)
    xlSheet.Range("G" & rCount) = "Email" 'Request Type
    xlSheet.Range("H" & rCount) = "Technical Information" 'Quote Category (Generator/ATS | Tank & Enclosure | Switchgear | Large Gas | Technical Information)
    xlSheet.Range("I" & rCount) = "5" 'Category Priority (1-5)
    xlSheet.Range("AJ" & rCount) = "Open"
    xlSheet.Range("AZ" & rCount) = "Open"
    xlSheet.Range("AX" & rCount) = "Open"
    xlSheet.Range("BA" & rCount) = "Open"
    xlSheet.Range("BE" & rCount) = "Open"
    xlSheet.Range("BG" & rCount) = "Open"
    'xlSheet.Range("BI" & rCount) = txtEmail 'Email body
    
    olItem.UnRead = True
    olItem.Move tiFolder
    
'Date and time from time stamp
    xlSheet.Range("AS" & rCount) = Format(olItem.ReceivedTime, "mm/dd/yyyy hh:mm:ss AM/PM")
    xlSheet.Range("AR" & rCount) = Format(olItem.ReceivedTime, "mm/dd/yyyy")
    xlSheet.Range("AT" & rCount) = "Automated" 'Created By
    
'ERRORHANDLER:
    
    Excel.Application.ScreenUpdating = True
    Excel.Application.DisplayAlerts = True
    
    xlSheet.Protect (Pass)
    
    xlWB.Save
    
    xlWB.Close savechanges:=True
    
    If bXStarted Then
        xlApp.Quit
    End If
    
    Set xlApp = Nothing
    Set xlWB = Nothing
    Set xlSheet = Nothing
    Set olkSnd = Nothing
    Set olkExu = Nothing
    
End Sub