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
 
Sort by date Sort by votes
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.
Click to expand...
That is exactly what I am trying to do, perfectly explained!

What I don't quite get is the range/cells are you comparing.
Click to expand...
I have been comparing cell by cell. I need to find all changes in a worksheet, ranging from Cell A1 to EA9300 ( This number can change as well).

Did that answer your question about the range?
 
Upvote 0

Excel Facts

Format cells as date
Select range and press Ctrl+Shift+3 to format cells as date. (Shift 3 is the # sign which sort of looks like a small calendar).
Is the data all numbers and are the ranges exactly the same on both worksheets?
 
Upvote 0
The data is a combination of numbers and characters. A small sample would be:

12345
45678
ABC Company
Bob Smith
Product is clean
ABC & DSF Team
5
6
1/2/2001
Click to expand...
Where each row would really be a new column (Stupid formatting). The ranges would be potentially different; there is a chance that someone could have deleted or added new rows. I am currently working on something to work around this, but it would basically be:

If row is in previous and not in current then
insert a row into current
if row is in current and not in previous
then insert row into previous and highlight row in current
 
Upvote 0
So is what you posted a 'record' and displayed something like this?

<TABLE style="WIDTH: 460pt; BORDER-COLLAPSE: collapse" border=0 cellSpacing=0 cellPadding=0 width=614><COLGROUP><COL style="WIDTH: 35pt; mso-width-source: userset; mso-width-alt: 1718" span=2 width=47><COL style="WIDTH: 74pt; mso-width-source: userset; mso-width-alt: 3620" width=99><COL style="WIDTH: 55pt; mso-width-source: userset; mso-width-alt: 2669" width=73><COL style="WIDTH: 86pt; mso-width-source: userset; mso-width-alt: 4169" width=114><COL style="WIDTH: 91pt; mso-width-source: userset; mso-width-alt: 4425" width=121><COL style="WIDTH: 11pt; mso-width-source: userset; mso-width-alt: 548" span=2 width=15><COL style="WIDTH: 62pt; mso-width-source: userset; mso-width-alt: 3035" width=83><TBODY><TR style="HEIGHT: 15pt" height=20><TD style="BORDER-BOTTOM: windowtext 0.5pt solid; BORDER-LEFT: windowtext 0.5pt solid; BACKGROUND-COLOR: transparent; WIDTH: 35pt; HEIGHT: 15pt; BORDER-TOP: windowtext 0.5pt solid; BORDER-RIGHT: windowtext 0.5pt solid" class=xl63 height=20 width=47 align=right>12345


</TD><TD style="BORDER-BOTTOM: windowtext 0.5pt solid; BORDER-LEFT: windowtext; BACKGROUND-COLOR: transparent; WIDTH: 35pt; BORDER-TOP: windowtext 0.5pt solid; BORDER-RIGHT: windowtext 0.5pt solid" class=xl63 width=47 align=right>45678</TD><TD style="BORDER-BOTTOM: windowtext 0.5pt solid; BORDER-LEFT: windowtext; BACKGROUND-COLOR: transparent; WIDTH: 74pt; BORDER-TOP: windowtext 0.5pt solid; BORDER-RIGHT: windowtext 0.5pt solid" class=xl63 width=99>ABC Company</TD><TD style="BORDER-BOTTOM: windowtext 0.5pt solid; BORDER-LEFT: windowtext; BACKGROUND-COLOR: transparent; WIDTH: 55pt; BORDER-TOP: windowtext 0.5pt solid; BORDER-RIGHT: windowtext 0.5pt solid" class=xl63 width=73>Bob Smith</TD><TD style="BORDER-BOTTOM: windowtext 0.5pt solid; BORDER-LEFT: windowtext; BACKGROUND-COLOR: transparent; WIDTH: 86pt; BORDER-TOP: windowtext 0.5pt solid; BORDER-RIGHT: windowtext 0.5pt solid" class=xl63 width=114>Product is clean</TD><TD style="BORDER-BOTTOM: windowtext 0.5pt solid; BORDER-LEFT: windowtext; BACKGROUND-COLOR: transparent; WIDTH: 91pt; BORDER-TOP: windowtext 0.5pt solid; BORDER-RIGHT: windowtext 0.5pt solid" class=xl63 width=121>ABC & DSF Team</TD><TD style="BORDER-BOTTOM: windowtext 0.5pt solid; BORDER-LEFT: windowtext; BACKGROUND-COLOR: transparent; WIDTH: 11pt; BORDER-TOP: windowtext 0.5pt solid; BORDER-RIGHT: windowtext 0.5pt solid" class=xl63 width=15 align=right>5</TD><TD style="BORDER-BOTTOM: windowtext 0.5pt solid; BORDER-LEFT: windowtext; BACKGROUND-COLOR: transparent; WIDTH: 11pt; BORDER-TOP: windowtext 0.5pt solid; BORDER-RIGHT: windowtext 0.5pt solid" class=xl63 width=15 align=right>6</TD><TD style="BORDER-BOTTOM: windowtext 0.5pt solid; BORDER-LEFT: windowtext; BACKGROUND-COLOR: transparent; WIDTH: 62pt; BORDER-TOP: windowtext 0.5pt solid; BORDER-RIGHT: windowtext 0.5pt solid" class=xl64 width=83 align=right>01/02/2001</TD></TR></TBODY></TABLE>
 
Upvote 0
Haven't checked this but try running it:

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
Set rm = Sheets("RM Data List")
'Sheets("RM Data List").Select

Set chngWB = Workbooks("Changes.xlsm")
rm.Copy After:=chngWB.Sheets(1)
Set prev = ActiveSheet
prev.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
Set srcSht = Sheets("Source Data")
'Sheets("Source Data").Select

srcSht.Copy After:=chngWB.Sheets(1)
Set crnt = ActiveSheet
crnt.Name = "Current"

Application.Calculation = xlCalculationManual

If prev.Cells(1, 1) = "" Then
    With prev.Cells
        First_Row = .Find(what:="*", searchorder:=xlByRows).Row
        First_Col = .Find(what:="*", searchorder:=xlByColumns).Column
    End With
Else
    First_Col = 1
    First_Row = 1
End If
last_row = prev.UsedRange.Rows.Count + First_Row - 1
last_col = prev.UsedRange.Columns.Count + First_Col - 1
Set prevRng = prev.Range(prev.Cells(1, 1), prev.Cells(last_row, last_col))

With prevRng
    .NumberFormat = "General"
    .Replace what:="", Replacement:="BLANK", LookAt:=xlPart, _
            searchorder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
            ReplaceFormat:=False
End With
prev.Range("A1").Select

If crnt.Cells(1, 1) = "" Then
    With crnt.Cells
        First_Row = .Find(what:="*", searchorder:=xlByRows).Row
        First_Col = .Find(what:="*", searchorder:=xlByColumns).Column
    End With
Else
    First_Col = 1
    First_Row = 1
End If
crntlast_row = crnt.UsedRange.Rows.Count + First_Row - 1
crntlast_col = crnt.UsedRange.Columns.Count + First_Col - 1
Set crntRng = crnt.Range(crnt.Cells(1, 1), crnt.Cells(last_row, last_col))

With prevRng
    .NumberFormat = "General"
    .Replace what:="", Replacement:="BLANK", LookAt:=xlPart, _
            searchorder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
            ReplaceFormat:=False
End With
crnt.Range("A1").Select

If crntlast_col > last_col Then last_col = crntlast_col
If crntlast_row > last_row Then last_row = crntlast_row

For j = 1 To last_col
    For i = 1 To last_row
    If prev.Cells(i, j) <> crnt.Cells(i, j) Then
        With crnt.Cells(i, j)
            .Pattern = xlSolid
            .PatternColorIndex = xlAutomatic
            .ThemeColor = xlThemeColorAccent5
            .TintAndShade = 0
            .PatternTintAndShade = 0
        End With
    End If
    
    If j = last_col and i = last_row Then
        crnt.Activate
        Cells(i + 1, 1).Select
     End If
    Next i
Next j

Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub
 
Last edited:
Upvote 0
Thank you for the optimized code jkoudsi. It is still too long however.

I had a new thought: I can filter some of the data out, reducing the amount of rows from 9300 to about 820. However, when I create this filter, the code still acts as if the hidden cells are there and continues on its merry way. Is there a way to skip through the hidden cells and only compare the visible filtered cells? Preferably with vba code; I need minimal user interaction!

Thank you!
 
Upvote 0
How would you be filtering the data?

One thing I actually forgot to ask, so think anyway, was how exactly are you comparing the 2 sets of data?

You did mention it was by cell but there must be something more to it.

For example is the example you posted a 'record' and you need to compare that with the corresponding 'record' in the other date set?

Also, is there any way to link the data?

Perhaps the 'records' have the same ID on both worksheets.
 
Upvote 0
How would you be filtering the data?
Click to expand...

By filtering the data by manager. The data is in table format, and the user can select which data they would like to see based on the manager.

One thing I actually forgot to ask, so think anyway, was how exactly are you comparing the 2 sets of data?

You did mention it was by cell but there must be something more to it.

For example is the example you posted a 'record' and you need to compare that with the corresponding 'record' in the other date set?

Also, is there any way to link the data?

Perhaps the 'records' have the same ID on both worksheets.
Click to expand...

They are 'records', with a same id on both worksheets, which works when needing to find any rows (records) that have been added or deleted. The main goal is to find any changes within the cells themselves, which is why I am going cell by cell. For example, records 1234 will be the same on both worksheets, with the only difference being on worksheet "Previous", the date is 01/02/2001 and on the worksheet "current" the date become 11/31/2002.

Would a better way to do this perhaps be to include an entire row in an array? Can Excel create an array that will hold 70+ items?
 
Upvote 0
Why not use the ID to find the 2 related records and compare them?

That's exactly how it would be done in something like Access and there's no reason you can't do something similar in Excel.

Does that make sense?
 
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,506
Messages
6,179,159
Members
452,892
Latest member
yadavagiri

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