Solved

VBA macro slow after upgrading office

Posted on 2016-07-18
4
42 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
[X]
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
4 Comments
 
LVL 19

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

Revamp Your Training Process

Drastically shorten your training time with WalkMe's advanced online training solution that Guides your trainees to action.

Question has a verified solution.

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

When you see single cell contains number and text, and you have to get any date out of it seems like cracking our heads.
In Part II of this series, I will discuss how to identify all open instances of Excel and enumerate the workbooks, spreadsheets, and named ranges within each of those instances.
Hi friends,  in this video  I'll show you how new windows 10 user can learn the using of windows 10. Thank you.
Finds all prime numbers in a range requested and places them in a public primes() array. I've demostrated a template size of 30 (2 * 3 * 5) but larger templates can be built such 210  (2 * 3 * 5 * 7) or 2310  (2 * 3 * 5 * 7 * 11). The larger templa‚Ķ

733 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