Slow Calculations After Macro - Normal After Save or Reload

[Jeffrey Mahoney]

I've searched around and can't find anything exactly like what I'm experiencing. I just recently upgraded to Office 2016, but the problem happened on Office 2013 also.

My workbook contains no more than 300 formulas. Half of them are pretty simple IF statements. The other half are AGGREGATE formulas that support pulldowns for data validation. I have about 120 named ranges. About 40 of them are dynamic named ranges using OFFSET and MATCH.

In my opinion, it's not a very complicated workbook and not with a ton of data. I've had way bigger files without this issue. The file size is 8.6mb

I have two macros that import data from other workbooks; tables of data from SAP. The macros import the data and create some summary tables. The summary tables support the data validation.

After either one of these macros finish my whole workbook bogs down. I enter a value in a cell and the calculations take about 5-10 seconds to finish. I can see it calculating the entire workbook twice.

If I save the file everything is back to normal. If I close the workbook and reopen it, everything is back to normal.

I have several other macros that import data from SAP. They don't alter the tables that support the validation pulldowns. The problem does not occur after they run.

Has anybody else experienced this?

Sub ImportOLA()


  Dim Cel As Range
  Dim R As Range
  Dim OutR As Range
  Dim A As String
  Dim TWB As Workbook
  Dim wb As Workbook
  Dim CraftSht As Worksheet
  Dim VendSht As Worksheet
  Dim Setup As Worksheet
  Dim ImpWB As Workbook
  Dim ImpSht As Worksheet
  Dim u As Range
  Dim Key1 As Range
  Dim Key2 As Range
  Dim Key3 As Range
  Dim VendorRpt As Variant
  Dim PCN() As Variant
  Dim IntHdrs() As Variant
  Dim iTL As Range
  Dim Cnt As Long
  Dim Hdrs As Range
  Dim vHdrs As Range
  Dim vTL As Range
  Dim cHdrs As Range
  Dim cTL As Range
  Dim mTL As Range
  Dim m As Variant
  Dim i As Variant
  Dim v As Variant
  Dim X As Long
  Dim VendCol As Range
  Dim OLADescCol As Range
  Dim Vend As Long
  
  Set TWB = ThisWorkbook
  Set CraftSht = TWB.Sheets("Craft Codes")
  Set VendSht = TWB.Sheets("Vendors")
  Set Setup = TWB.Sheets("Setup")
  
  
  For Each wb In Application.Workbooks
    If UCase(wb.Name) = "EXPORT.XLSX" Then
      v = MsgBox("Use 'Export.XLSX' for the import?", vbYesNoCancel)
      If v = vbYes Then
        Set ImpWB = wb
        Set ImpSht = wb.Sheets("Sheet1")
        ImpSht.Activate
        Exit For
      End If
      
    ElseIf UCase(wb.Name) = "REPORTSMASTER.ASPX" Then
      v = MsgBox("Use 'REPORTSMASTER.ASPX' for the import?", vbYesNoCancel)
      If v = vbYes Then
        Set ImpWB = wb
        Set ImpSht = wb.Sheets("ContractorMasterData")
        ImpSht.Activate
        Exit For
      End If
      
    End If
    
  Next wb
  
  If ImpSht Is Nothing Then
    On Error Resume Next
    Set v = Application.InputBox("Please select a cell on the sheet containing the new Master Data", "Select a Cell", Type:=8)
    On Error GoTo 0
    If v = False Then Exit Sub
    
    A = v.Parent.Parent.Name
    Set ImpWB = Workbooks(A)
    Set ImpSht = ImpWB.Sheets(v.Parent.Name)
    ImpSht.Activate
  End If
  
  
  Application.Calculation = xlCalculationManual
  Application.EnableEvents = False
  Application.ScreenUpdating = False


  
  
  
  'Clear out old values in craft tables
  Set Cel = CraftSht.Range("CraftTemp_hdr").Offset(1, 0)
  Set R = CraftSht.Range(Cel, Cel.Offset(10000, 4))
  R.ClearContents
  
  'Clear out old values in temp Vendor OLA table
  Set Cel = VendSht.Range("VendDup2_hdr").Offset(1, 0)
  Set R = VendSht.Range(Cel, Cel.Offset(10000, 4))
  R.ClearContents
  
  
  'Is it a Admin Portal or a Vendor Portal Report?
  Set Cel = ImpSht.Range("A1")
  Set R = Range(Cel, Cel.End(xlToRight))
  m = Application.Match("Service Validity Sta", R, False)
  VendorRpt = IsError(m)
  
  'Get the Import report column names
  If VendorRpt = False Then
    Set R = Setup.Range("OLAAdminHeaders")
  Else
    Set R = Setup.Range("OLAVendorHeaders")
  End If
  Cnt = R.Count
  PCN() = Application.Transpose(R.Value)
  Set R = Setup.Range("OLAInternalHeaders")
  IntHdrs() = Application.Transpose(R.Value)
  
  'Finally!  get the new data; find each header in the report and match with Master Data
  Set iTL = ImpSht.Range("A1")
  Set Hdrs = ImpSht.Range(iTL, iTL.End(xlToRight))  'Headers in import sheet
  Set vTL = VendSht.Range("VendDup2_hdr")
  Set vHdrs = VendSht.Range(vTL, vTL.End(xlToRight))
  Set cTL = CraftSht.Range("CraftTemp_hdr")
  Set cHdrs = CraftSht.Range(cTL, cTL.End(xlToRight))
  
  For X = 1 To Cnt                                        'Column names one by one
    If PCN(X) <> "*NONE*" Then
      m = Application.Match(PCN(X), Hdrs, False)            'search for each column name
      If IsError(m) Then
        MsgBox "The OLA Report you are trying to import doesn't have the right columns. Couldn't find " & PCN(X) & " Import not complete"
        GoTo ouch33
      End If
      Set Cel = iTL.Offset(1, m - 1)
      With ImpSht
        Set R = Range(Cel, .Cells(.Cells.Rows.Count, Cel.Column).End(xlUp))
      End With
      i = Application.Match(IntHdrs(X), vHdrs, False)                       'Search Vendor OLA Temp table
      If IsError(i) = False Then
        Set Cel = vTL.Offset(1, i - 1)
        Set OutR = VendSht.Range(Cel, Cel.Offset(R.Rows.Count - 1, 0))
        OutR.Value = R.Value
      End If
      i = Application.Match(IntHdrs(X), cHdrs, False)                       'Search Craft Temp table
      If IsError(i) = False Then
        Set Cel = cTL.Offset(1, i - 1)
        Set OutR = CraftSht.Range(Cel, Cel.Offset(R.Rows.Count - 1, 0))
        OutR.Value = R.Value
      End If
      
    End If
  Next X
  
  
  
  '------------------------------------------------------------
  'CRAFT
  
  Set u = Nothing               'remove non craft rows in temp table
  With CraftSht
    Set R = .Range(cTL.Offset(1, 0), .Cells(.Cells.Rows.Count, cTL.Column).End(xlUp))
  End With
  For Each Cel In R
    If Cel.Offset(0, 2).Value = "" Then
      If Not u Is Nothing Then
        Set u = Union(u, Range(Cel, Cel.Offset(0, 3)))
      Else
        Set u = Range(Cel, Cel.Offset(0, 3))
      End If
    
    Else
      Cel.Offset(0, 4).Value = Cel.Offset(0, 2).Value & " * " & Cel.Offset(0, 3).Value
    End If
  Next Cel
  If Not u Is Nothing Then
    u.ClearContents
  End If
    
    
  With CraftSht
    Set Cel = .Range("CraftTemp_hdr")                        'Setup sort for craft Build
    Set R = .Range(Cel, .Cells(.Cells.Rows.Count, Cel.Column).End(xlUp).Offset(0, 4))
    Set Key1 = .Range(Cel.Offset(0, 1), .Cells(.Cells.Rows.Count, Cel.Column).End(xlUp).Offset(0, 1))
    Set Key2 = .Range(Cel.Offset(0, 2), .Cells(.Cells.Rows.Count, Cel.Column).End(xlUp).Offset(0, 2))
  End With
  
  CraftSht.Sort.SortFields.Clear
  CraftSht.Sort.SortFields.Add Key:=Key1, SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
  CraftSht.Sort.SortFields.Add Key:=Key2, SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
  With CraftSht.Sort
    .SetRange R
    .Header = xlYes
    .MatchCase = False
    .Orientation = xlTopToBottom
    .SortMethod = xlPinYin
    .Apply
  End With
    
    
  With CraftSht
    Set Cel = .Range("CraftTemp_hdr")                        'Remove duplicates in Craft table (Build)
    Set R = .Range(Cel, .Cells(.Cells.Rows.Count, Cel.Column).End(xlUp).Offset(0, 4))
  End With
  R.RemoveDuplicates Columns:=Array(1, 3), Header:=xlYes
  
  With CraftSht
    Set Cel = .Range("CraftTemp_hdr").Offset(1, 0)                       'Copy Craft temp to craft table
    Set R = .Range(Cel, .Cells(.Cells.Rows.Count, Cel.Column).Offset(0, 4))
    Set Cel = .Range("CraftTable_hdr").Offset(1, 0)
    Set OutR = .Range(Cel, .Cells(.Cells.Rows.Count, Cel.Column).Offset(0, 4))
    OutR.Value = R.Value
  End With
  
  
  Set u = Nothing
   With VendSht                                          'Find and remove non labor in Vendor OLA build
    Set Cel = .Range("VendDup2_hdr").Offset(1, 0)
    Set R = .Range(Cel, .Cells(.Cells.Rows.Count, Cel.Column).End(xlUp))
  End With
  For Each Cel In R
    If Cel.Offset(0, 4).Value <> "LAB" Then
      If Not u Is Nothing Then
        Set u = Union(Range(Cel, Cel.Offset(0, 4)), u)
      Else
        Set u = Range(Cel, Cel.Offset(0, 4))
      End If
    End If
  Next Cel
  If Not u Is Nothing Then
    u.ClearContents
  End If
  
  
  With VendSht
    Set Cel = .Range("VendDup2_hdr")                        'Remove duplicates in Craft table (Build)
    Set R = .Range(Cel, .Cells(.Cells.Rows.Count, Cel.Column).End(xlUp).Offset(0, 4))
  End With
  R.RemoveDuplicates Columns:=Array(1, 3, 4), Header:=xlYes
  
  
  With VendSht
    Set Cel = .Range("VendDup2_hdr")                        'Setup sort for Vendor OLA Build
    Set R = .Range(Cel, .Cells(.Cells.Rows.Count, Cel.Column).End(xlUp).Offset(0, 4))
    Set Key1 = .Range(Cel.Offset(0, 1), .Cells(.Cells.Rows.Count, Cel.Column).End(xlUp).Offset(0, 1))
    Set Key2 = .Range(Cel.Offset(0, 2), .Cells(.Cells.Rows.Count, Cel.Column).End(xlUp).Offset(0, 2))
    Set Key3 = .Range(Cel.Offset(0, 3), .Cells(.Cells.Rows.Count, Cel.Column).End(xlUp).Offset(0, 3))
  End With
  
  VendSht.Sort.SortFields.Clear
  VendSht.Sort.SortFields.Add Key:=Key1, SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
  VendSht.Sort.SortFields.Add Key:=Key2, SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
  VendSht.Sort.SortFields.Add Key:=Key3, SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
  With VendSht.Sort
    .SetRange R
    .Header = xlYes
    .MatchCase = False
    .Orientation = xlTopToBottom
    .SortMethod = xlPinYin
    .Apply
  End With
  
  With VendSht
    Set Cel = .Range("VendDup2_hdr").Offset(1, 0)                       'Copy Vend OLA build to Vend OLA table
    Set R = .Range(Cel, .Cells(.Cells.Rows.Count, Cel.Column).Offset(0, 3))
    Set Cel = .Range("VendOLA_hdr").Offset(1, 0)
    Set OutR = .Range(Cel, .Cells(.Cells.Rows.Count, Cel.Column).Offset(0, 3))
    OutR.Value = R.Value
  End With
  
  
                                                'Per Diem and Paid Meal
  With ImpSht                                   'Set the vendor and OLA Service Desc columns
    m = Application.Match("Vendor", Hdrs, False)
    Set Cel = iTL.Offset(1, m - 1)
    Set VendCol = .Range(Cel, .Cells(.Cells.Rows.Count, Cel.Column).End(xlUp))
    m = Application.Match("OLA Service Descript", Hdrs, False)
    Set Cel = iTL.Offset(1, m - 1)
    Set OLADescCol = .Range(Cel, .Cells(.Cells.Rows.Count, Cel.Column).End(xlUp))
  End With
    
  With VendSht                                  'Set the Vendor number column in the list of vendors
    Set Cel = .Range("VendTbl_hdr").Offset(1, 5)
    Set R = .Range(Cel, .Cells(.Cells.Rows.Count, Cel.Column + 1))
    R.ClearContents
    
    Set Cel = .Range("VendTbl_hdr").Offset(1, 0)
    Set R = .Range(Cel, .Cells(.Cells.Rows.Count, Cel.Column).End(xlUp))
    For Each Cel In R                                                      'Set the Per Diem and Paid Meal boolean
      Vend = Cel.Value
      If Application.CountIfs(VendCol, Vend, OLADescCol, "*per diem*") > 0 Then
        Cel.Offset(0, 5).Value = True
      End If
      If Application.CountIfs(VendCol, Vend, OLADescCol, "*meal*") > 0 Then
        Cel.Offset(0, 6).Value = True
      End If
    Next Cel
  End With
  
  
  TWB.Sheets("Start").Range("OLAImportDate").Value = Now()
  
  ImpWB.Close savechanges:=False
  
  
ouch33:
  
  Application.Calculation = xlCalculationAutomatic
  Application.EnableEvents = True
  Application.ScreenUpdating = True
  TWB.Activate


  
End Sub

 

[Sumitpal SIngh Sandhu]

Try to keep the Calculation to Manual only. This might helps u

 

[Jeffrey Mahoney]

Not a very helpful suggestion. I'm trying to get to the reason why. This workbook is going to be used by a very larger group of people. The formulas control the pulldown menus in cells, if they have the calculation set to manual, then the whole things is useless.

 

[Jeffrey Mahoney]

UPDATE: If I save the workbook, close it, and re-open it everything is normal.

Is there an equivalent VBA command to close and reopen?

I have tried Application.CalculateFullRebuild

 

[Jeffrey Mahoney]

Correction: It works great after I simply save it. No need to save, close, and re-open

Any Ideas out there?