Database freezes after running a subroutine, I cannot click on anything in the form

[Moosee]

I created a button on my form to allow me to report out many queries to an Excel file. This works great, the Excel file is created with many tabs containing data, but after it has completed, I am unable to click anything on the form and the database is frozen. The only thing I can do is close the database. I have stepped through the code and I am not getting any errors, but everything I have tried results in the same frozen database. I have made sure that closed the recordsets and the Excel file.

[June7]

Post your code or attach files - follow instructions at bottom of my post.

[Moosee]

Private Sub cmdExportReports_Click()
' This procedure exports the reports to an Excel file.
   
   Dim NewWBName As String
   Dim WBName As String
   Dim DTAddress As String
   Dim strObjectType As String
   Dim strObjectName As String
   Dim strSheetName As String
   Dim strFileName As String
   
   On Error GoTo ErrorHandler
   
   DoCmd.Hourglass True
   
   DTAddress = CreateObject("WScript.Shell").SpecialFolders("Desktop") & ""
   WBName = "CRA_Suspense_Reports_" & Format(Now, "yyyymmdd_hhmmss") & ".xlsx"
   NewWBName = DTAddress & WBName
   
   ExportToExcel "qry_Report_by_Error_With_Percentages", "By Error", NewWBName


   AppendToExcel "qry_Report_By_Files", "By Files", NewWBName
   AppendToExcel "qry_Report_Aging_By_Month_Final", "Aging By Month", NewWBName
   AppendToExcel "qry_Report_By_CRA", "By CRA", NewWBName
   AppendToExcel "qry_Report_Command_Account_Final", "Command Accounts", NewWBName
   AppendToExcel "qry_Report_Summary_Final", "Summary", NewWBName
   AppendToExcel "qry_Report_Detail", "Detail", NewWBName
   
   DoCmd.Hourglass False
   MsgBox "The report has been created on the desktop " & WBName


   Exit Sub
   
ErrorHandler:
   ' Display error information.
   MsgBox "Error number " & Err.Number & ": " & Err.Description
   ' Resume following occurrence of error.
   Resume Next


End Sub


Public Sub ExportToExcel(strObjectName As String, strSheetName As String, strFileName As String)
' This procedure exports the first report and saves the orginal Excel workbook for all of the
' rest of the reports to be sent.


   Dim intCount As Integer
   Dim db As DAO.Database
   Dim rst As DAO.Recordset
   Dim XL As Excel.Application
   Dim WB As Excel.Workbook
   Dim WS As Excel.Worksheet
   Dim LastRow As Long
   
   Application.Echo False
    
   On Error GoTo ExportToExcel_Err
   Set db = CurrentDb
   
   Set rst = db.OpenRecordset(strObjectName)


   If rst.RecordCount = 0 Then
      MsgBox "No records to be exported."
   Else
      On Error Resume Next
      Set XL = GetObject(, "Excel.Application")
      If Err.Number <> 0 Then
         Set XL = CreateObject("Excel.Application")
      End If
      Err.Clear
      On Error GoTo ExportToExcel_Err
      Set WB = XL.Workbooks.Add
      XL.Visible = False
      Set WS = WB.Worksheets("Sheet1")
      If Len(strSheetName) > 0 Then
         WS.Name = Left(strSheetName, 31)
      End If


      WS.Range("A1").Select
      Do Until intCount = rst.Fields.Count
         XL.ActiveCell = rst.Fields(intCount).Name
         XL.ActiveCell.Offset(0, 1).Select
         intCount = intCount + 1
      Loop


      rst.MoveFirst
        
      WS.Range("A2").CopyFromRecordset rst


      With XL
         .Range("A1").Select
         .Range(.Selection, .Selection.End(xlToRight)).Select
         .Selection.Interior.Pattern = xlSolid
         .Selection.Interior.PatternColorIndex = xlAutomatic
         .Selection.Interior.TintAndShade = -0.25
         .Selection.HorizontalAlignment = xlCenter
         .Selection.Font.Bold = True
         .Cells.EntireColumn.AutoFit
      '   .Visible = True
      End With
        
      LastRow = LastCell(ActiveSheet).Row
      If strSheetName = "By Error" Then
         Columns("B:B").Select
         Selection.Style = "Currency"
         Columns("C:C").Select
         Selection.NumberFormat = "0.00%"
         Range("B" & LastRow + 1).Select
         ActiveCell.Formula = "=sum(B2:B" & LastRow & ")"
         Selection.Font.Bold = True
         Range("C" & LastRow + 1).Select
         ActiveCell.Formula = "=sum(C2:C" & LastRow & ")"
         Selection.Font.Bold = True
         XL.Cells.EntireColumn.AutoFit
         XL.Range("A1").Select
      End If


      WB.SaveAs strFileName
      WB.Close
      rst.Close
      Set rst = Nothing
      
   End If
   Exit Sub


ExportToExcel_Err:
   DoCmd.SetWarnings True
   MsgBox Err.Description, vbExclamation, Err.Number
   Resume Next
   
End Sub

Public Sub AppendToExcel(strObjectName As String, strSheetName As String, strFileName As String)
' This procedure appends the rest of the reports into the first created Excel file.


   Dim rst As DAO.Recordset
   Dim XL As Excel.Application
   Dim WB As Excel.Workbook
   Dim WS As Excel.Worksheet
   Dim intCount As Integer
   
   On Error GoTo ErrorHandler
   
   Application.Echo False
   
   Set rst = CurrentDb.OpenRecordset(strObjectName)
    
   If rst.RecordCount = 0 Then
      MsgBox "No records to be exported."
   Else
      On Error Resume Next
      Set XL = GetObject(, "Excel.Application")
      If Err.Number <> 0 Then
         Set XL = CreateObject("Excel.Application")
      End If
      Err.Clear


      XL.Visible = False
        
      Set WB = XL.Workbooks.Open(strFileName)
      Set WS = WB.Sheets.Add
      WS.Name = Left(strSheetName, 31)
       
      WS.Range("A1").Select
      Do Until intCount = rst.Fields.Count
         XL.ActiveCell = rst.Fields(intCount).Name
         XL.ActiveCell.Offset(0, 1).Select
         intCount = intCount + 1
      Loop


      rst.MoveFirst
        
      WS.Range("A2").CopyFromRecordset rst
      rst.Close
      Set rst = Nothing
      
      With XL
         .Range("A1").Select
         .Range(.Selection, .Selection.End(xlToRight)).Select
         .Selection.Interior.Pattern = xlSolid
         .Selection.Interior.PatternColorIndex = xlAutomatic
         .Selection.Interior.TintAndShade = -0.25
         .Selection.HorizontalAlignment = xlCenter
         .Selection.Font.Bold = True
         .Cells.EntireRow.AutoFit
         .ActiveSheet.Cells.EntireColumn.AutoFit
       End With
        
      LastRow = LastCell(ActiveSheet).Row
      If strSheetName = "By Files" Then
         Columns("E:E").Select
         Selection.Style = "Currency"
         Range("E" & LastRow + 1).Select
         ActiveCell.Formula = "=sum(E2:E" & LastRow & ")"
         Selection.Font.Bold = True
      ElseIf strSheetName = "Aging By Month" Then
         Columns("C:C").Select
         Selection.Style = "Currency"
         Columns("D:D").Select
         Selection.NumberFormat = "0.00%"
         Range("C" & LastRow + 1).Select
         Selection.Font.Bold = True
         ActiveCell.Formula = "=sum(C2:C" & LastRow & ")"
         Selection.Font.Bold = True
         Range("D" & LastRow + 1).Select
         ActiveCell.Formula = "=sum(D2:D" & LastRow & ")"
         Selection.Font.Bold = True
         Columns("E:F").Select
         Selection.Delete Shift:=xlToLeft
      ElseIf strSheetName = "By CRA" Then
         Columns("C:C").Select
         Selection.Style = "Currency"
         Range("C" & LastRow + 1).Select
         ActiveCell.Formula = "=sum(C2:C" & LastRow & ")"
         Selection.Font.Bold = True
      ElseIf strSheetName = "Command Accounts" Then
         Columns("B:B").Select
         Selection.Style = "Currency"
         Columns("C:C").Select
         Selection.NumberFormat = "0.00%"
         Range("B" & LastRow + 1).Select
         ActiveCell.Formula = "=sum(B2:B" & LastRow & ")"
         Selection.Font.Bold = True
         Range("C" & LastRow + 1).Select
         ActiveCell.Formula = "=sum(C2:C" & LastRow & ")"
         Selection.Font.Bold = True
      ElseIf strSheetName = "Summary" Then
         Columns("B:B").Select
         Selection.Style = "Currency"
         Columns("E:E").Select
         Selection.NumberFormat = "0.00%"
         Range("B" & LastRow + 1).Select
         ActiveCell.Formula = "=sum(B2:B" & LastRow & ")"
         Selection.Font.Bold = True
         Range("C" & LastRow + 1).Select
         ActiveCell.Formula = "=sum(C2:C" & LastRow & ")"
         Selection.Font.Bold = True
         Range("D" & LastRow + 1).Select
         ActiveCell.Formula = "=sum(D2:D" & LastRow & ")"
         Selection.Font.Bold = True
         Range("E" & LastRow + 1).Select
         ActiveCell.Formula = "=sum(E2:E" & LastRow & ")"
         Selection.Font.Bold = True
      End If
      XL.Cells.EntireColumn.AutoFit
      WS.Range("A1").Select


      WB.Close True
      WB = Nothing
      XL.Close
      Set XL = Nothing
        
    End If
    Exit Sub
    
ErrorHandler:
   ' Display error information.
   MsgBox "Error number " & Err.Number & ": " & Err.Description
   ' Resume following occurrence of error.
   Resume Next
    
End Sub

[June7]

Please edit your post so code is posted between CODE tags (the # icon on editor menu) to retain indentation and readability and character combinations are not converted to emoji images.

That's a lot of code to work through and would have to set up files for testing. I am ready to abandon this thread. Would be better to provide file.

[CJ_London]

Suggest step through the code to see which line is causing the freeze

[Moosee]

I have stepped through the code and it executes to the end of the sub without errors, so I do not know how to determine what it making the DB freeze. I don't want to be clicking around in the form until it has completed and by then it is frozen. I am sorry, I am pretty new to coding in Access except for creating queries and such.

[Edgar]

If it runs fine but it freezes then how much data are you handling here? Reduce the amount of data to only a few records, does it still freeze? If all goes well then your program will need optimizations, if it freezes with a small amount of records then something else is wrong.

[CJ_London]

so I do not know how to determine what it making the DB freeze

seems to me you set application.echo to false and never set it to true - so the screen remains frozen. This would be the same whether you step through the code or not, so when you stepped through you should have noticed the screen was still frozen - see this link

https://learn.microsoft.com/en-us/of...plication.Echo

As an aside, your code would be more efficient to have a global excel object and keep the excel file open until done rather than constantly saving, reopening then saving again

[Micron]

Call me a dabbler in Excel vba for sure, but I also suspect there's room for optimization.
For one thing, selecting ranges is usually not necessary to work with them.

When you select B:B to do something like formatting, you are selecting and formatting over a million rows. The result of such operations is often that it slows things down considerably, and you are doing that sort of thing a LOT. Also, I am not 100% certain but I believe you can both copy and pastespecial to affect target cell formatting without selecting either cell. Not helpful if the formatting cannot be copied from an existing cell, I know.

In optimizing I would also consider whether or not the wb has events that will run when you are programmatically changing cell values. F'rinstance, if your code changes cell selection and target values, code will likely run for both events if you have any, adding to the slow down.

Resume Next is a dangerous thing to do carte blanche. You can get caught in a loop doing that if expecting only one error, which is what I see there. Not necessarily an infinite loop, but a loop nonetheless.

Can't see what LastCell does, so maybe it's OK; maybe not if you're figuring that out via UsedRange property.

Last thing I'll mention is that if I alter application level properties, I pretty much always use an error handler to ensure they are restored. You're not doing that.

[Moosee]

Call me a dabbler in Excel vba for sure, but I also suspect there's room for optimization.
For one thing, selecting ranges is usually not necessary to work with them.

When you select B:B to do something like formatting, you are selecting and formatting over a million rows. The result of such operations is often that it slows things down considerably, and you are doing that sort of thing a LOT. Also, I am not 100% certain but I believe you can both copy and pastespecial to affect target cell formatting without selecting either cell. Not helpful if the formatting cannot be copied from an existing cell, I know.

In optimizing I would also consider whether or not the wb has events that will run when you are programmatically changing cell values. F'rinstance, if your code changes cell selection and target values, code will likely run for both events if you have any, adding to the slow down.

Resume Next is a dangerous thing to do carte blanche. You can get caught in a loop doing that if expecting only one error, which is what I see there. Not necessarily an infinite loop, but a loop nonetheless.

Can't see what LastCell does, so maybe it's OK; maybe not if you're figuring that out via UsedRange property.

Last thing I'll mention is that if I alter application level properties, I pretty much always use an error handler to ensure they are restored. You're not doing that.

I will do as you suggest and let everyone know the outcome. Thank you.

[Moosee]

I will do all that everyone has suggested and let you know the results. Thanks to all for the help.

[Moosee]

"set application.echo to false and never set it to true"

Pretty sure this was the problem, still trying to incorporate the other suggestions. Thanks to all.

[Edgar]

Remove the .Select and the .ActiveCell references. Figure out the ranges instead of applying formatting to the entire column, use the Find method to find the last cell, it is the fastest and most precise. Instead of pasting cell references, put the data into an array and paste the array, then format the content.