The code runs slowly [VBA]

[Martin_H]

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.

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

 

[Fluff]

May not be a lot quicker, but how about

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

 

[Martin_H]

Thank you for your reply Fluff but it is pretty much same.

I appreciate it.

 

[Fluff]

Ok, how about

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

 

[Martin_H]

A whole second faster than the previous one

 

[Fluff]

How many blank cells are you likely to have in col B?

 

[Martin_H]

How many blank cells are you likely to have in col B?

Currently, the last occupied cell in column B in the ß_PCF worksheet is 127, none of which are empty.

 

[Fluff]

In that case you could get rid of this line

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

although it make not any further improvement.

 

[Martin_H]

Awesome!
Now we are less than half a second in total

Thank you Fluff.

 

[Fluff]

You're welcome & thanks for the feedback.