Martin_H
Board Regular
- Joined
- Aug 26, 2020
- Messages
- 190
- Office Version
- 365
- Platform
- 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.
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