Is there a way to speed up my code which copy a heavily formula infested worksheet
and creates a multiple new sheets? (cont'd title question)
My vba code copies 1 hidden tab and creates a number of new sheets on that basis with a different name (name is specified by the user in a section of the excel workbook). The problem is that the hidden tab (that one which is copied) has got a significant number of formulas (about 100 rows x10 columns - most formulas a lookups/vlookups). It means creation of each new sheet take a lot of time - about 25 second each. I need to have calculation on as the results of formulas in each new tab are required for a further processing.
The users i built it for complained that it is long time.
I want to add that i already tried with switching on Application.Calculation = xlAutomatic at the end of the code but the results were pretty much identical as putting 'Calculate' in the middle as it is now.
How can i speed up my vba procedure (i can add that i already use Application. property with a various actions switched off - as per below example)? OR is there no chance to improve speed if you worksheets are so heavily formula infested.
Code:
Sub ConvertInput() ' put the user's input from the named range into the array
Dim i As Integer
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.DisplayAlerts = False
Application.Calculation = xlCalculationManual
Application.StatusBar = False
If wsToDuplicate.Visible = xlSheetVeryHidden Or wsToDuplicate.Visible = xlSheetHidden Then
wsToDuplicate.Visible = xlSheetVisible
End If
myArray = Range("rng_Target").Value
For i = LBound(myArray) To UBound(myArray)
If IsEmpty(myArray(i, 1)) = False Then 'check if the element of myarray is empty or if there is any value there (string)
wsToDuplicate.Copy After:=Sheets(Sheets.Count)
With ActiveSheet
.name = myArray(i, 1)
End With
End If
'This fragment is only to test whether array works
'MsgBox myArray(i, 1)
'Debug.Print myArray(i, 1)
Next i
Erase myArray() ' Clear array
Calculate
If wsToDuplicate.Visible = xlSheetVisible Or wsToDuplicate.Visible = xlSheetHidden Then
wsToDuplicate.Visible = xlSheetVeryHidden
End If
Call X
Application.ScreenUpdating = True
Application.EnableEvents = True
Application.DisplayAlerts = True
'Application.Calculation = xlCalculationAutomatic
Application.StatusBar = True
End Sub
Sub X()
Dim LastRemR As Integer
For Each wrksh In ThisWorkbook.Worksheets
LastRemR = 119
If wrksh.name <> "TB" And wrksh.name <> "Lead - TO DELETE" And wrksh.name <> "Lead list & MAT" And _
wrksh.name <> "Input" Then
wrksh.Activate
With wrksh.Range("M20:M119")
.Value = .Value
End With
With wrksh.Columns("M").SpecialCells(xlCellTypeConstants)
LastR = .Cells(.Cells.Count).Row + 1
End With
Rows(LastR & ":" & LastRemR).Delete
On Error GoTo Correct:
'Check the last row again to extend the borders to the last cell of the table
With wrksh.Columns("M").SpecialCells(xlCellTypeConstants)
LastR = .Cells(.Cells.Count).Row
End With
GoTo Borders:
Correct:
LastR = 20
Borders:
wrksh.Range("B" & LastR & ":" & "L" & LastR).Borders.LineStyle = xlContinuous
End If
Next wrksh
End Sub
