patternModerate
Macro that does some kind of duplicate check
Viewed 0 times
duplicatekindthatsomemacrodoescheck
Problem
This macro pulls in two workbooks, one being a template with saved formulas already, and the other containing data with thousands of rows...I need to increase the speed because the process takes more than 15 minutes.
```
Sub WbtoWb4()
Dim Wb1 As Workbook
Dim Wb2 As Workbook
With Application
.ScreenUpdating = False
.EnableEvents = False
.DisplayAlerts = False
End With
Set Wb1 = Workbooks.Open("")
Set Wb2 = Workbooks.Open("")
Wb1.Sheets("CDGL Data").Copy After:=Wb2.Sheets("STS")
Wb1.Close False
With Application
.ScreenUpdating = True
.EnableEvents = True
.DisplayAlerts = True
End With
Sheets("CDGL Data").Select
Range("AQ:BB").EntireColumn.Delete
Range("A1").AutoFilter Field:=32, Criteria1:=Sheets("DataSources").Range("B4").Value
ActiveSheet.UsedRange.Offset(1, 0).SpecialCells _
(xlCellTypeVisible).Copy
Sheets("CDGL").Select
Range("B2").PasteSpecial Paste:=xlPasteValues
With Sheets("CDGL")
rows_c1 = .Cells(Rows.Count, "G").End(xlUp).Row
Sheets("Duplicate Check").Range("A1:C" & rows_c1).Value = Sheets("CDGL").Range("H2:J" & rows_c1).Value
rows_c2 = .Cells(Rows.Count, "K").End(xlUp).Row
Sheets("Duplicate Check").Range("D1:G" & rows_c2).Value = Sheets("CDGL").Range("L2:O" & rows_c2).Value
rows_c3 = .Cells(Rows.Count, "AI").End(xlUp).Row
Sheets("Duplicate Check").Range("H1:H" & rows_c3).Value = Sheets("CDGL").Range("AJ2:AJ" & rows_c3).Value
End With
Sheets("Duplicate Check").Select
Set rng = Range("A1", Range("H1").End(xlDown))
rng.RemoveDuplicates Columns:=Array(1, 2, 3, 4, 5, 6, 7, 8), Header:=xlNo
With Sheets("CDGL")
Sheets("Rec").Range("B6").Resize(.Cells(.Rows.Count, "G").End(xlUp).Row - 1, 3).Value = Sheets("Duplicate Check").Range("A1:C" & .Cells(.Rows.Count, "A").End(xlUp).Row).Value
Sheets("Rec").Range("E6").Resize(.Cells(.Rows.Count, "D").End(xlUp).Row - 1, 4).Value = Sheets("Duplicate Check").Range("D1:G" & .Cells(.Rows.Count, "A").End(xlUp).Row).Value
Sheets("Rec").Range("I6").Resize(.Cells(.Rows.Count, "H").End(xlUp).Row - 1, 1).Value = Sheets("
```
Sub WbtoWb4()
Dim Wb1 As Workbook
Dim Wb2 As Workbook
With Application
.ScreenUpdating = False
.EnableEvents = False
.DisplayAlerts = False
End With
Set Wb1 = Workbooks.Open("")
Set Wb2 = Workbooks.Open("")
Wb1.Sheets("CDGL Data").Copy After:=Wb2.Sheets("STS")
Wb1.Close False
With Application
.ScreenUpdating = True
.EnableEvents = True
.DisplayAlerts = True
End With
Sheets("CDGL Data").Select
Range("AQ:BB").EntireColumn.Delete
Range("A1").AutoFilter Field:=32, Criteria1:=Sheets("DataSources").Range("B4").Value
ActiveSheet.UsedRange.Offset(1, 0).SpecialCells _
(xlCellTypeVisible).Copy
Sheets("CDGL").Select
Range("B2").PasteSpecial Paste:=xlPasteValues
With Sheets("CDGL")
rows_c1 = .Cells(Rows.Count, "G").End(xlUp).Row
Sheets("Duplicate Check").Range("A1:C" & rows_c1).Value = Sheets("CDGL").Range("H2:J" & rows_c1).Value
rows_c2 = .Cells(Rows.Count, "K").End(xlUp).Row
Sheets("Duplicate Check").Range("D1:G" & rows_c2).Value = Sheets("CDGL").Range("L2:O" & rows_c2).Value
rows_c3 = .Cells(Rows.Count, "AI").End(xlUp).Row
Sheets("Duplicate Check").Range("H1:H" & rows_c3).Value = Sheets("CDGL").Range("AJ2:AJ" & rows_c3).Value
End With
Sheets("Duplicate Check").Select
Set rng = Range("A1", Range("H1").End(xlDown))
rng.RemoveDuplicates Columns:=Array(1, 2, 3, 4, 5, 6, 7, 8), Header:=xlNo
With Sheets("CDGL")
Sheets("Rec").Range("B6").Resize(.Cells(.Rows.Count, "G").End(xlUp).Row - 1, 3).Value = Sheets("Duplicate Check").Range("A1:C" & .Cells(.Rows.Count, "A").End(xlUp).Row).Value
Sheets("Rec").Range("E6").Resize(.Cells(.Rows.Count, "D").End(xlUp).Row - 1, 4).Value = Sheets("Duplicate Check").Range("D1:G" & .Cells(.Rows.Count, "A").End(xlUp).Row).Value
Sheets("Rec").Range("I6").Resize(.Cells(.Rows.Count, "H").End(xlUp).Row - 1, 1).Value = Sheets("
Solution
Lowest-Hanging VBA Performance Fruit
You have
But you only have it in force for part of your Sub. If you move this
To the very end of your Sub, you should instantly see a big improvement.
In addition, you should set
Always Reset anything you disable
Whenever you change an
is never set back to
You have
With Application
.ScreenUpdating = False
.EnableEvents = False
.DisplayAlerts = False
End WithBut you only have it in force for part of your Sub. If you move this
With Application
.ScreenUpdating = True
.EnableEvents = True
.DisplayAlerts = True
End WithTo the very end of your Sub, you should instantly see a big improvement.
In addition, you should set
Application.Calculate to xlCalculationManual at the start, and set it back to xlCalculationAutomatic at the end. That's the other big performance drain.Always Reset anything you disable
Whenever you change an
Application.Thing setting, that change will persist as long as Excel remains open. This:Application.DisplayAlerts = Falseis never set back to
True. Once your Sub ends, if your user accidentally clicks the close button, Excel will close without prompting them to save their work first. Because alerts are disabled.Code Snippets
With Application
.ScreenUpdating = False
.EnableEvents = False
.DisplayAlerts = False
End WithWith Application
.ScreenUpdating = True
.EnableEvents = True
.DisplayAlerts = True
End WithApplication.DisplayAlerts = FalseContext
StackExchange Code Review Q#132520, answer score: 15
Revisions (0)
No revisions yet.