Welcome to Experts Exchange

Add your voice to the tech community where 5M+ people, just like you, are talking about what matters.

  • Help others & share knowledge
  • Earn cash & points
  • Learn & ask questions
Solved

VBA macro slow after upgrading office

Posted on 2016-07-18
4
40 Views
Last Modified: 2016-08-15
Hi Experts,

I have a few PC's which were recently upgraded to from 7 to Windows 10 and from office 2003 to office 2016.

after doing so all PC's which have been upgraded are taking significantly longer to run a macro.

the document is saved in Microsoft Excel 97-2003 worksheet. It does open it in compatibility mode (which may be my problem).

just incase it is code related I have attached it below hoping a wiz will point out mistakes / ways to speed it up.


Public Sub Letters()
    Dim ownerSheetName As String, nonSheetName As String
    Dim sourceRow As Integer, lastRow As Integer
    Dim ownerRow As Integer, nonRow As Integer
    Dim source As Worksheet, ownerSheet As Worksheet, nonSheet As Worksheet
    Dim startDateO As Date, endDateO As Date
    Dim startDateN As Date, endDateN As Date
    Dim leadsSheet As Worksheet, leadsLength As Integer
    Dim regNumber As String
    
    ownerSheetName = "OWN " & Replace(DateTime.Date, "/", "-")
    Set ownerSheet = FindSheetByName(ownerSheetName)
    If ownerSheet Is Nothing Then
        Set ownerSheet = Sheets.Add(after:=Sheets(Sheets.Count))
        ownerSheet.name = ownerSheetName
    End If
    AddColumnHeaders ownerSheet
    ownerRow = 2
    While ownerSheet.Cells(ownerRow, 1) <> ""
        ownerRow = ownerRow + 1
    Wend
    startDateO = DateTime.Date + 2
    endDateO = DateTime.Date + 10
    
    nonSheetName = "NON " & Replace(DateTime.Date, "/", "-")
    Set nonSheet = FindSheetByName(nonSheetName)
    If nonSheet Is Nothing Then
        Set nonSheet = Sheets.Add(after:=Sheets(Sheets.Count))
        nonSheet.name = nonSheetName
    End If
    AddColumnHeaders nonSheet
    nonRow = 2
    While nonSheet.Cells(nonRow, 1) <> ""
        nonRow = nonRow + 1
    Wend
    startDateN = DateTime.Date + 1
    endDateN = DateTime.Date + 8
    
    Set leadsSheet = Sheets("Leads")
    leadsLength = 2
    While leadsSheet.Cells(leadsLength, 1) <> ""
        leadsLength = leadsLength + 1
    Wend
    
    Set source = Sheets("Driving-Test-Dates")
    sourceRow = 2
    lastRow = source.UsedRange.Rows(source.UsedRange.Rows.Count).Row
    
    copiedCount = 0
    dupeCount = 0
    
    While sourceRow <= lastRow
        If source.Cells(sourceRow, 30) = "" And source.Cells(sourceRow, 1) <> "" Then
            regNumber = source.Cells(sourceRow, 16).Value
            If Right(source.Cells(sourceRow, 24), 2) = "OW" Then
                If source.Cells(sourceRow, 2) >= startDateO And source.Cells(sourceRow, 2) <= endDateO Then
                    If FindDuplicateRegNo(regNumber, source, lastRow) Then
                        source.Cells(sourceRow, 30).Value = regNumber
                        dupeCount = dupeCount + 1
                    Else
                        CopyDataToSubSheet source, sourceRow, ownerSheet, ownerRow
                        ownerRow = ownerRow + 1
                        copiedCount = copiedCount + 1
                        source.Cells(sourceRow, 30).Value = regNumber
                    End If
                End If
            Else
                If source.Cells(sourceRow, 2) >= startDateN And source.Cells(sourceRow, 2) <= endDateN Then
                    If FindDuplicateRegNo(regNumber, source, lastRow) Then
                        source.Cells(sourceRow, 30).Value = regNumber
                        dupeCount = dupeCount + 1
                    Else
                        CopyDataToSubSheet source, sourceRow, nonSheet, nonRow
                        nonRow = nonRow + 1
                        copiedCount = copiedCount + 1
                        source.Cells(sourceRow, 30).Value = regNumber
                    End If
                End If
            End If
            
            
        End If
        
        sourceRow = sourceRow + 1
    Wend
    
    MsgBox copiedCount & " rows added"
    MsgBox dupeCount & " duplicate rows ignored"

End Sub

Private Function FindDuplicateRegNo(regNumber As String, source As Worksheet, lastRow As Integer) As String
    Set findRN = source.Range("AD2:AD" & lastRow).Find(What:=regNumber, LookIn:=xlValues, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False)
    FindDuplicateRegNo = False
    If Not findRN Is Nothing Then
        If CDate(source.Cells(findRN.Row, 2)) > CDate("16-May-2016") Then
            FindDuplicateRegNo = True
        End If
    End If
End Function

Private Function FindSheetByName(name As String) As Worksheet
    For Each ws In Sheets
        If ws.name = name Then
            Set FindSheetByName = ws
            Exit Function
        End If
    Next ws
End Function

Private Sub AddColumnHeaders(dest As Worksheet)
    dest.Cells(1, 1) = "ID"
    dest.Cells(1, 2) = "driving_test_date"
    dest.Cells(1, 3) = "firstname"
    dest.Cells(1, 4) = "fullname"
    dest.Cells(1, 5) = "address 1"
    dest.Cells(1, 6) = "address 2"
    dest.Cells(1, 7) = "address 3"
    dest.Cells(1, 8) = "address 4"
    dest.Cells(1, 9) = "address 5"
    dest.Cells(1, 10) = "address 6"
    dest.Cells(1, 11) = "postcode"
    dest.Cells(1, 12) = "email"
    dest.Cells(1, 13) = "covernote_prefix"
End Sub

Private Sub CopyDataToSubSheet(source As Worksheet, sourceRow As Integer, dest As Worksheet, destRow As Integer)
    dest.Cells(destRow, 1).Value = source.Cells(sourceRow, 1).Value   'Policy ID
    dest.Cells(destRow, 2).Value = source.Cells(sourceRow, 2).Value  'Driving Test Date
    dest.Cells(destRow, 3).Value = source.Cells(sourceRow, 4).Value  'Firstname
    dest.Cells(destRow, 4).Value = source.Cells(sourceRow, 5).Value  'Fullname
    
    addressLines = Split(source.Cells(sourceRow, 6), ",")
    For i = 0 To UBound(addressLines)
        dest.Cells(destRow, 5 + i).Value = Trim(addressLines(i))
    Next i
    
    dest.Cells(destRow, 11).Value = source.Cells(sourceRow, 7).Value  'Postcode
    dest.Cells(destRow, 12).Value = source.Cells(sourceRow, 9).Value  'Email
    dest.Cells(destRow, 13).Value = source.Cells(sourceRow, 24).Value 'Covernote_prefix
End Sub

Public Sub DrivingTestEditMQ()
    Dim sourceRow As Integer, lastRow As Integer, destRow As Integer
    Dim source As Worksheet, dest As Worksheet
    
    Set source = Sheets("Driving-Test-Dates")
    sourceRow = 2
    Set dest = Sheets("Leads")
    destRow = 2
    
    copiedCount = 0
    
    dest.Select
    ActiveWindow.Zoom = 100
    
    While dest.Cells(destRow, 1) <> ""
        destRow = destRow + 1
    Wend
    
    lastRow = source.UsedRange.Rows(source.UsedRange.Rows.Count).Row
    
    While sourceRow <= lastRow
        If source.Cells(sourceRow, 16) <> "" Then
            regNumber = source.Cells(sourceRow, 16).Value
            Set findRN = dest.Range("O2:O" & destRow).Find(What:=regNumber, LookIn:=xlValues, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False)
            If findRN Is Nothing Then
                dest.Cells(destRow, 1).Value = source.Cells(sourceRow, 24).Value  'Policy Type
                dest.Cells(destRow, 4).Value = source.Cells(sourceRow, 1).Value   'Policy ID
                dest.Cells(destRow, 5).Value = source.Cells(sourceRow, 2).Value  'Driving Test Date
                dest.Cells(destRow, 6).Value = source.Cells(sourceRow, 4).Value  'Firstname
                dest.Cells(destRow, 7).Value = source.Cells(sourceRow, 5).Value  'Fullname
                dest.Cells(destRow, 8) = source.Cells(sourceRow, 28)  'Phone Number
                dest.Cells(destRow, 9).Value = source.Cells(sourceRow, 7).Value  'Postcode
                dest.Cells(destRow, 10).Value = source.Cells(sourceRow, 8).Value 'DOB
                dest.Cells(destRow, 11).Value = source.Cells(sourceRow, 12).Value 'ILD Start_Cover
                dest.Cells(destRow, 12).Value = source.Cells(sourceRow, 13).Value 'ILD End_Cover
                dest.Cells(destRow, 13).Value = source.Cells(sourceRow, 14).Value 'Make
                dest.Cells(destRow, 14).Value = source.Cells(sourceRow, 15).Value 'Model
                dest.Cells(destRow, 15).Value = source.Cells(sourceRow, 16).Value 'Reg No
                dest.Cells(destRow, 16).Value = source.Cells(sourceRow, 18).Value 'Premium
                dest.Cells(destRow, 17).Value = source.Cells(sourceRow, 24).Value 'Type
                
                dest.Cells(destRow, 8).NumberFormat = "@"
                dest.Range("A" & destRow & ":AA" & destRow).HorizontalAlignment = xlCenter
                
                With dest.Cells(destRow, 1)
                    .FormatConditions.Delete
                    .FormatConditions.Add Type:=xlCellValue, Operator:=xlEqual, Formula1:="=""MSILDOW"""
                    .FormatConditions(1).Interior.ColorIndex = 9
                End With
                With dest.Cells(destRow, 17)
                    .FormatConditions.Delete
                    .FormatConditions.Add Type:=xlCellValue, Operator:=xlEqual, Formula1:="=""MSILDOW"""
                    .FormatConditions(1).Interior.ColorIndex = 9
                End With
    
                Set c = dest.Cells(destRow, 20)
                With dest.Buttons.Add(c.Left, c.Top, c.Width, c.Height)
                    .OnAction = "Btn_Click"
                    .Caption = "Insert Date"
                End With
                Set c = dest.Cells(destRow, 23)
                With dest.Buttons.Add(c.Left, c.Top, c.Width, c.Height)
                    .OnAction = "Btn_Click"
                    .Caption = "Insert Date"
                End With
                Set c = dest.Cells(destRow, 26)
                With dest.Buttons.Add(c.Left, c.Top, c.Width, c.Height)
                    .OnAction = "Btn_Click"
                    .Caption = "Insert Date"
                End With
                    
                destRow = destRow + 1
                copiedCount = copiedCount + 1
            End If
        End If
        
        sourceRow = sourceRow + 1
    Wend
    
    Range("A2:AZ" & destRow - 1).Sort Key1:=Range("E2"), Order1:=xlDescending, Header:=xlGuess, _
        OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
        DataOption1:=xlSortNormal

    MsgBox copiedCount & " rows added"
End Sub

Private Sub Btn_Click()
    Set btn2 = Sheets("Leads").Buttons(Application.Caller)
    With btn2.TopLeftCell
        btnRow = .Row
        btnCol = .Column
    End With
        
    Sheets("Leads").Cells(btnRow, btnCol) = Now()
    btn2.Delete
End Sub

Open in new window

0
Comment
Question by:peggiegreg
4 Comments
 
LVL 18

Expert Comment

by:Roy_Cox
ID: 41717446
I cannot see anything in the code that would cause significant drops in efficiency. Without seeing the workbook it's difficult to be sure but I would look at ways to avoid the Loops.

A dummy workbook would be useful
0
 
LVL 50

Accepted Solution

by:
Rgonzo1971 earned 500 total points
ID: 41717450
Hi,

You could change this construction
    ownerRow = 2
    While ownerSheet.Cells(ownerRow, 1) <> ""
        ownerRow = ownerRow + 1
    Wend

Open in new window

to this one
    ownerRow = ownerSheet.Cells(Rows.Count, 1).End(xlUp).offset(1)

Open in new window

and encase your Sub Letters code in

Application.ScreenUpdating = False
'Your Code
Application.ScreenUpdating = True

Open in new window

Regards
0

Featured Post

Ransomware: The New Cyber Threat & How to Stop It

This infographic explains ransomware, type of malware that blocks access to your files or your systems and holds them hostage until a ransom is paid. It also examines the different types of ransomware and explains what you can do to thwart this sinister online threat.  

Question has a verified solution.

If you are experiencing a similar issue, please ask a related question

Microsoft Office Picture Manager is not included in Office 2013. This comes as a shock to users upgrading from earlier versions of Office, such as 2007 and 2010, where Picture Manager was included as a standard application. This article explains how…
Describes a method of obtaining an object variable to an already running instance of Microsoft Access so that it can be controlled via automation.
This Micro Tutorial will demonstrate in Google Sheets how to use the HYPERLINK function to create live links inside your spreadsheet.
Excel styles will make formatting consistent and let you apply and change formatting faster. In this tutorial, you'll learn how to use Excel's built-in styles, how to modify styles, and how to create your own. You'll also learn how to use your custo…

809 members asked questions and received personalized solutions in the past 7 days.

Join the community of 500,000 technology professionals and ask your questions.

Join & Ask a Question