Solved

VBA macro slow after upgrading office

Posted on 2016-07-18
4
30 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 17

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 48

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

Why You Should Analyze Threat Actor TTPs

After years of analyzing threat actor behavior, it’s become clear that at any given time there are specific tactics, techniques, and procedures (TTPs) that are particularly prevalent. By analyzing and understanding these TTPs, you can dramatically enhance your security program.

Join & Write a Comment

If you use NetMotion Mobility on your PC and plan to upgrade to Windows 10, it may not work unless you take these steps.
Sometimes drives fill up and we don't know why.  If you don't understand the best way to use the tools available, you may end up being stumped as to why your drive says it's not full when you have no space left!  Here's how you can find out...
This Micro Tutorial will demonstrate in Microsoft Excel how to add style and sexy appeal to horizontal bar charts.
Access reports are powerful and flexible. Learn how to create a query and then a grouped report using the wizard. Modify the report design after the wizard is done to make it look better. There will be another video to explain how to put the final p…

762 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

Need Help in Real-Time?

Connect with top rated Experts

19 Experts available now in Live!

Get 1:1 Help Now