This code for saving worksheet is very slow

[JumboCactuar]

Hi,
This code I have to add new workbook > copy data from active sheet to Sheet1 of new workbook then save runs slow.

Private Sub SaveSheet()
Dim WB1 As Workbook, WB2 As Workbook
Dim WS1 As Worksheet, WS2 As Worksheet

NUMBERA = Sheets("Main").TextBox1.Value
LR = Range("A65000").End(xlUp).Row

Application.ScreenUpdating = False

Set WB1 = ActiveWorkbook
Set WS1 = ActiveSheet
Set WB2 = Workbooks.Add
Set WS2 = WB2.Sheets("Sheet1")
DoEvents

MyDir = "C:\TEST\"

WS2.Range("A1:Z" & LR).Value2 = WS1.Range("A1:Z" & LR).Value2

WB2.SaveAs MyDir & NUMBERA & ".xlsx"
WB2.Close

Application.screenupdating = true

End Sub

Also even with screenupdating disabled I still see a blank excel window with "saving" prompt

Anyone know a better way to do this?

Any help appreciated

 

[DanteAmor]

Remove the doevents line and add line to calculation

Private Sub SaveSheet()
  Dim WB1 As Workbook, WB2 As Workbook
  Dim WS1 As Worksheet, WS2 As Worksheet
  
  NUMBERA = Sheets("Main").TextBox1.Value
  lr = Range("A65000").End(xlUp).Row
  
  Application.ScreenUpdating = False
[COLOR=#0000ff]  Application.Calculation = xlCalculationManual[/COLOR]
  Set WB1 = ActiveWorkbook
  Set WS1 = ActiveSheet
  Set WB2 = Workbooks.Add
  Set WS2 = WB2.Sheets("Sheet1")
  MyDir = "C:\TEST\"
  WS2.Range("A1:Z" & lr).Value2 = WS1.Range("A1:Z" & lr).Value2
  WB2.SaveAs MyDir & NUMBERA & ".xlsx"
  WB2.Close False
  Application.ScreenUpdating = True
[COLOR=#0000ff]  Application.Calculation = xlCalculationAutomatic[/COLOR]
End Sub