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.
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
