VBA code optimization

L

Lorlai

Board Regular
Joined
May 26, 2011
Messages
85
I am comparing two sheets, trying to find changes. These sheets contain large amounts of data (From Columns A:DA, and over 9,000 rows). Because of this, my code is incredibly slow, taking up to 30 min to run. Is there a way to optimize my code? I have already turned off automatic calculations and the screen update. Any help with this would be appreciated!!

Code: 
Sub Test()
Application.ScreenUpdating = False
'Getting Ready to Name the final sheet
Dim TodayDate As String
TodayDate = Format(Date, "mmm-dd-yyyy")

'Choosing a previous file
MsgBox "Please choose a previous File"
PreviousWorkbook = Application.GetOpenFilename _
(Title:="Please choose a previous file", _
FileFilter:="Excel Files *.xls* (*.xls*),")
''
If PreviousWorkbook = False Then
MsgBox "No file specified.", vbExclamation, "Error"
Exit Sub
Else
Workbooks.Open Filename:=PreviousWorkbook
End If

'Copying the Source data from the Previous File to the Changes Workbook
Sheets("RM Data List").Select
ActiveSheet.Copy After:=Workbooks("Changes.xlsm").Sheets(1)
ActiveSheet.Name = "Previous"

'Choosing a current file
MsgBox "Please choose the Current File"
CurrentWorkbook = Application.GetOpenFilename _
(Title:="Please choose the current file", _
FileFilter:="Excel Files *.xls* (*.xls*),")
''
If CurrentWorkbook = False Then
MsgBox "No file specified.", vbExclamation, "Error"
Exit Sub
Else
Workbooks.Open Filename:=CurrentWorkbook
End If

'Copying the Source Data from the Current file to the Changes Workbook
Sheets("Source Data").Select
ActiveSheet.Copy After:=Workbooks("Changes.xlsm").Sheets(1)
ActiveSheet.Name = "Current"


Application.Calculation = xlCalculationManual

Sheets("Previous").Select
Columns("A:DZ").Select
    Selection.NumberFormat = "General"
    Selection.Replace What:="", Replacement:="BLANK", LookAt:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False
Range("A1").Select

Sheets("Current").Select
Columns("A:DZ").Select
    Selection.NumberFormat = "General"
    Selection.Replace What:="", Replacement:="BLANK", LookAt:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False
Range("A1").Select

Do
Sheets("Previous").Select
CellValue = ActiveCell.Value

Sheets("Current").Select
    If ActiveCell.Value <> CellValue Then
    With Selection.Interior
        .Pattern = xlSolid
        .PatternColorIndex = xlAutomatic
        .ThemeColor = xlThemeColorAccent5
        .TintAndShade = 0
        .PatternTintAndShade = 0
    End With
    End If
ActiveCell.Offset(0, 1).Select

Sheets("Previous").Select
ActiveCell.Offset(0, 1).Select

If IsEmpty(ActiveCell) Then
    Sheets("Previous").Select
    ActiveCell.Offset(1, 0).Select
    ActiveSheet.Cells(ActiveCell.Row, 1).Select
    Sheets("Current").Select
    ActiveCell.Offset(1, 0).Select
    ActiveSheet.Cells(ActiveCell.Row, 1).Select
End If

Loop Until IsEmpty(ActiveCell)

Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub
 

Excel Facts

Wildcard in VLOOKUP
Use =VLOOKUP("Apple*" to find apple, Apple, or applesauce
Sort by date Sort by votes
you could take out a lot of you ".Select"s and see if that's faster. Give me a few minutes.
 
Upvote 0
I'm sorry, my real job is getting busy. I don't have time to look at anything this big right now, so to speak.
 
Upvote 0
Thanks for offering to look it over anyway! Can I ask you a quick question about these .select statements? I put most of this together from recording macros, so I'm not certain how to get rid of the .select. Can you give me a quick example about this? If it's too much work, then no problem! I appreciate the help :)

Lorelai
 
Upvote 0
with a lot of things, you don't need to select. such as...
Code: 
Range("A1").Select
Selection.Formula="Test"
becomes
Code: 
Range("A1").Formula = "Test"
 
Upvote 0
Thank you for that tip. That sped things up slightly, but it is still taking over 25 minutes to run. Are there any other tips to speed this up/make this better?

Code: 
Sub Test()
Application.ScreenUpdating = False
'Getting Ready to Name the final sheet
Dim TodayDate As String
TodayDate = Format(Date, "mmm-dd-yyyy")

'Choosing a previous file
MsgBox "Please choose a previous File"
PreviousWorkbook = Application.GetOpenFilename _
(Title:="Please choose a previous file", _
FileFilter:="Excel Files *.xls* (*.xls*),")
''
If PreviousWorkbook = False Then
MsgBox "No file specified.", vbExclamation, "Error"
Exit Sub
Else
Workbooks.Open Filename:=PreviousWorkbook
End If

'Copying the Source data from the Previous File to the Changes Workbook
Sheets("Source Data").Copy After:=Workbooks("Changes.xlsm").Sheets(1)
ActiveSheet.Name = "Previous"

'Choosing a current file
MsgBox "Please choose the Current File"
CurrentWorkbook = Application.GetOpenFilename _
(Title:="Please choose the current file", _
FileFilter:="Excel Files *.xls* (*.xls*),")
''
If CurrentWorkbook = False Then
MsgBox "No file specified.", vbExclamation, "Error"
Exit Sub
Else
Workbooks.Open Filename:=CurrentWorkbook
End If

'Copying the Source Data from the Current file to the Changes Workbook
Sheets("Source Data").Copy After:=Workbooks("Changes.xlsm").Sheets(1)
ActiveSheet.Name = "Current"


Application.Calculation = xlCalculationManual

Sheets("Previous").Select
Columns("A:DZ").Select
    Selection.NumberFormat = "General"
    Selection.Replace What:="", Replacement:="BLANK", LookAt:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False
Range("A1").Select

Sheets("Current").Select
Columns("A:DZ").Select
    Selection.NumberFormat = "General"
    Selection.Replace What:="", Replacement:="BLANK", LookAt:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False
Range("A1").Select

Do
Sheets("Previous").Select
CellValue = ActiveCell.Value

Sheets("Current").Select
    If ActiveCell.Value <> CellValue Then
    With Selection.Interior
        .Pattern = xlSolid
        .PatternColorIndex = xlAutomatic
        .ThemeColor = xlThemeColorAccent5
        .TintAndShade = 0
        .PatternTintAndShade = 0
    End With
    End If
ActiveCell.Offset(0, 1).Select

Sheets("Previous").ActiveCell.Offset(0, 1).Select

If IsEmpty(ActiveCell) Then
    Sheets("Previous").Select
    ActiveCell.Offset(1, 0).Select
    ActiveSheet.Cells(ActiveCell.Row, 1).Select
    Sheets("Current").Select
    ActiveCell.Offset(1, 0).Select
    ActiveSheet.Cells(ActiveCell.Row, 1).Select
End If

Loop Until IsEmpty(ActiveCell)

Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub
 
Upvote 0
see if this is any faster
(do this on a copy of your data)

Code: 
Sub Test()
Application.ScreenUpdating = False
    'Getting Ready to Name the final sheet
    Dim TodayDate As String
    TodayDate = Format(Date, "mmm-dd-yyyy")
    
    'Choosing a previous file
    MsgBox "Please choose a previous File"
    PreviousWorkbook = Application.GetOpenFilename _
        (Title:="Please choose a previous file", _
        FileFilter:="Excel Files *.xls* (*.xls*),")
    ''
    If PreviousWorkbook = False Then
        MsgBox "No file specified.", vbExclamation, "Error"
        Exit Sub
    Else
        Workbooks.Open Filename:=PreviousWorkbook
    End If
    
    'Copying the Source data from the Previous File to the Changes Workbook
    Sheets("Source Data").Copy After:=Workbooks("Changes.xlsm").Sheets(1)
    ActiveSheet.Name = "Previous"
    
    'Choosing a current file
    MsgBox "Please choose the Current File"
    CurrentWorkbook = Application.GetOpenFilename _
        (Title:="Please choose the current file", _
        FileFilter:="Excel Files *.xls* (*.xls*),")
    ''
    If CurrentWorkbook = False Then
        MsgBox "No file specified.", vbExclamation, "Error"
        Exit Sub
    Else
        Workbooks.Open Filename:=CurrentWorkbook
    End If
    
    'Copying the Source Data from the Current file to the Changes Workbook
    Sheets("Source Data").Copy After:=Workbooks("Changes.xlsm").Sheets(1)
    ActiveSheet.Name = "Current"
    
    
    Application.Calculation = xlCalculationManual
    
    With Sheets("Previous").Columns("A:DZ")
        .NumberFormat = "General"
        .Replace What:="", Replacement:="BLANK", LookAt:=xlPart, _
            SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
            ReplaceFormat:=False
    End With
    
    With Sheets("Current").Columns("A:DZ")
        .NumberFormat = "General"
        .Replace What:="", Replacement:="BLANK", LookAt:=xlPart, _
            SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
            ReplaceFormat:=False
    End With
    
    Do
        Sheets("Previous").Select
        CellValue = ActiveCell.Value
        
        Sheets("Current").Select
        If ActiveCell.Value <> CellValue Then
            With Selection.Interior
                .Pattern = xlSolid
                .PatternColorIndex = xlAutomatic
                .ThemeColor = xlThemeColorAccent5
                .TintAndShade = 0
                .PatternTintAndShade = 0
            End With
        End If
        ActiveCell.Offset(0, 1).Select
        
        
        Sheets("Previous").ActiveCell.Offset(0, 1).Select
        
        If IsEmpty(ActiveCell) Then
            Sheets("Previous").Select
            ActiveCell.Offset(1, 1).Select
            Sheets("Current").Select
            ActiveCell.Offset(1, 1).Select
        End If
        
    Loop Until IsEmpty(ActiveCell)
    
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
End Sub

I have some other ideas to speed this up, but I've got to do some tests and critical thinking first.
 
Upvote 0
You really need to redo the loop part, that's probably the most time consuming part of the code.

I had a look at it but I can't figure out what it's actually doing.

That's mainly because of all the selecting and the use of ActiveCell.

That makes it unclear what's actually active.

A couple of other things you could try:

1 Close the workbooks once you've copied the worksheet from them.

2 Restrict the find/replace a bit - it's currently running on 136 million cells, or thereabouts.
 
Upvote 0
In my loop, I am trying to:
Select the previous sheet
store the cell value into variable CellValue
Select the current sheet
compare CellValue to current cell
if they do not match, then highlight the Current Cell
move over one cell to the right
switch to previous sheet
move one cell to the right
start loop over
If the cell is empty, then move one cell down
return to beginning of row
start loop over
repeat until empty cell that has empty cell at beginning of line.
Code: 
Do
        Sheets("Previous").Select
        CellValue = ActiveCell.Value
        
        Sheets("Current").Select
        If ActiveCell.Value <> CellValue Then
            With Selection.Interior
                .Pattern = xlSolid
                .PatternColorIndex = xlAutomatic
                .ThemeColor = xlThemeColorAccent5
                .TintAndShade = 0
                .PatternTintAndShade = 0
            End With
        End If
        ActiveCell.Offset(0, 1).Select
        
        
        Sheets("Previous").Select
        ActiveCell.Offset(0, 1).Select
        
        If IsEmpty(ActiveCell) Then
            Sheets("Previous").Select
            ActiveCell.Offset(1, 0).Select
            ActiveSheet.Cells(ActiveCell.Row, 1).Select
            Sheets("Current").Select
            ActiveCell.Offset(1, 0).Select
            ActiveSheet.Cells(ActiveCell.Row, 1).Select
        End If
        
    Loop Until IsEmpty(ActiveCell)
2. Restrict the find/replace a bit - it's currently running on 136 million cells, or thereabouts.
Click to expand...
What would be a good way to slim this down? I need to find all the empty cells and fill them with something, (like BLANK) in order for my loop to work. I'm not sure of another way to do this.
 
Upvote 0
2. Depending on the data you could just use something like CurrentRegion or UsedRange.

You could also use a bit of code to determine the last row and column of the data.

1. You don't need to do any of that selecting/switching/juggling with the worksheets and cells.

Is this what you are trying to do?

For each cell with data in it on the Previous sheet check the corresponding cell on the Current sheet, and highlight the cell on the current sheet if it's different?

eg if A1 on Current sheet is 10 and A1 on Previous sheet is 20, highliht A1 on Current Sheet.

What I don't quite get is the range/cells are you comparing.

Is it just one column of data? A whole range?
 
Upvote 0
You must log in or register to reply here.

Similar threads

D
  • Solved
Trying to copy data from a specific sheet in one workbook to another with VBA
Replies
2
Views
152
druck21
D
V
  • Question Question
US/European Date Format Updates Not Working on Macro Run
Replies
0
Views
117
vancher19
V
C
  • Solved
User Select PDF import to specific Excel sheet
2 3 4
Replies
31
Views
1K
John_w
J
H
  • Question Question
Copy Data where Source Workbook contains Name that is in destination sheet
Replies
4
Views
149
howard
H
T
  • Question Question
VBA Stuck Sanitising Several Sheets
Replies
2
Views
216
Tarkemelion
T

Forum statistics

Threads
1,224,504
Messages
6,179,142
Members
452,892
Latest member
JUSTOUTOFMYREACH

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