The code runs slowly [VBA]

Martin_H

Board Regular
Joined
Aug 26, 2020
Messages
190
Office Version
  1. 365
Platform
  1. Windows
Hi,

I use this code (see below) to collect data from 4 different worksheets into a central worksheet called ß_PCF.

It works well, but it's a bit slow. It usually takes around 10 seconds.

It should be noted that this code runs in a shared and locked workbook.

Would it be possible to run it faster?

Thank you.

VBA Code:
Public CalcState As Long
Public EventState As Boolean
Public PageBreakState As Boolean

Sub OptimizeCode_Begin()
EventState = Application.EnableEvents
Application.EnableEvents = False
CalcState = Application.Calculation
Application.Calculation = xlCalculationManual
PageBreakState = ActiveSheet.DisplayPageBreaks
ActiveSheet.DisplayPageBreaks = False
End Sub

Sub OptimizeCode_End()
ActiveSheet.DisplayPageBreaks = PageBreakState
Application.Calculation = CalcState
Application.EnableEvents = EventState
End Sub


Sub Macro_ALL()
Application.ScreenUpdating = False
Call OptimizeCode_Begin

Sheets("ß_PCF").Range("B3:M500").ClearContents

Call Macro_PCF_1
Call Macro_PCF_2
Call Macro_PCF_3
Call Macro_PCF_4

Columns("B:B").SpecialCells(xlCellTypeBlanks).EntireRow.Delete

Range("A2:AD500").Select
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.Color = 15132390
.TintAndShade = 0
.PatternTintAndShade = 0
End With

Columns("C:M").AutoFit
Rows("3:500").RowHeight = 25
Range("B2").Select

Call OptimizeCode_End
Application.ScreenUpdating = True
End Sub


Sub Macro_PCF_1()
For Each ws In ActiveWorkbook.Worksheets
If ws.Name = "ß_PCF_1" Then
ws.Range("B3:M100").Copy Sheets("ß_PCF").Cells(Rows.Count, "b").End(xlUp).Offset(1)
End If
Next ws
End Sub


Sub Macro_PCF_2()
For Each ws In ActiveWorkbook.Worksheets
If ws.Name = "ß_PCF_2" Then
ws.Range("B3:M50").Copy Sheets("ß_PCF").Cells(Rows.Count, "b").End(xlUp).Offset(1)
End If
Next ws
End Sub


Sub Macro_PCF_3()
For Each ws In ActiveWorkbook.Worksheets
If ws.Name = "ß_PCF_3" Then
ws.Range("B3:M100").Copy Sheets("ß_PCF").Cells(Rows.Count, "b").End(xlUp).Offset(1)
End If
Next ws
End Sub


Sub Macro_PCF_4()
For Each ws In ActiveWorkbook.Worksheets
If ws.Name = "ß_PCF_4" Then
ws.Range("B3:M50").Copy Sheets("ß_PCF").Cells(Rows.Count, "b").End(xlUp).Offset(1)
End If
Next ws
End Sub
 

Excel Facts

How to find 2nd largest value in a column?
MAX finds the largest value. =LARGE(A:A,2) will find the second largest. =SMALL(A:A,3) will find the third smallest
May not be a lot quicker, but how about
VBA Code:
Sub Macro_ALL()
Application.ScreenUpdating = False
Dim Ary As Variant
Dim i As Long

Ary = Array("ß_PCF_1", 100, "ß_PCF_2", 50, "ß_PCF_3", 100, "ß_PCF_4", 50)
Call OptimizeCode_Begin

Sheets("ß_PCF").Range("B3:M500").ClearContents
For i = 0 To UBound(Ary) Step 2
   Sheets(Ary(i)).Range("B3:M" & Ary(i + 1)).Copy Sheets("ß_PCF").Cells(Rows.Count, "b").End(xlUp).Offset(1)
Next i

Columns("B:B").SpecialCells(xlCellTypeBlanks).EntireRow.Delete

Range("A2:AD500").Select
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.Color = 15132390
.TintAndShade = 0
.PatternTintAndShade = 0
End With

Columns("C:M").AutoFit
Rows("3:500").RowHeight = 25
Range("B2").Select

Call OptimizeCode_End
Application.ScreenUpdating = True
End Sub
 
Upvote 0
Thank you for your reply Fluff but it is pretty much same.

I appreciate it.
 
Upvote 0
Ok, how about
VBA Code:
Sub Macro_ALL()
Application.ScreenUpdating = False
Dim Ary As Variant, Dary As Variant
Dim i As Long

Ary = Array("ß_PCF_1", 100, "ß_PCF_2", 50, "ß_PCF_3", 100, "ß_PCF_4", 50)
Call OptimizeCode_Begin

Sheets("ß_PCF").Range("B3:M500").ClearContents
For i = 0 To UBound(Ary) Step 2
   Dary = Sheets(Ary(i)).Range("B3:M" & Ary(i + 1)).Value2
   Sheets("ß_PCF").Cells(Rows.Count, "b").End(xlUp).Offset(1).Resize(UBound(Dary), 12).Value = Dary
Next i

Columns("B:B").SpecialCells(xlCellTypeBlanks).EntireRow.Delete

With Range("A2:AD500").Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.Color = 15132390
.TintAndShade = 0
.PatternTintAndShade = 0
End With

Columns("C:M").AutoFit
Rows("3:500").RowHeight = 25
Range("B2").Select

Call OptimizeCode_End
Application.ScreenUpdating = True
End Sub
 
Upvote 0
How many blank cells are you likely to have in col B?
 
Upvote 0
In that case you could get rid of this line
VBA Code:
Columns("B:B").SpecialCells(xlCellTypeBlanks).EntireRow.Delete
although it make not any further improvement.
 
Upvote 0
Solution
Awesome!
Now we are less than half a second in total :alien:

Thank you Fluff.
 
Upvote 0

Forum statistics

Threads
1,223,894
Messages
6,175,252
Members
452,623
Latest member
Techenthusiast

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