In Macro Application.Status stops, xlsm Not Responding, finishes fine!

[shell_l_d]

Here's a strange one... still learning VBA...

I have an xlsm file created in MS Excel 2010.
It has 5 worksheets. Sheet1 ("Update") has 2 DTPickers & a command button to run a macro (DataExtract).

When I run my macro it works fine, however part way through the Title Bar shows ...xlsm (Not Responding) & the status bar stops updating (still shows 'PLEASE WAIT... WaitOnCust ...'), however the macro finishes fine (all 3 worksheets populated with data) & shows the msgbox 'Update data complete' & the title bar no longer shows (Not Responding) & the status bar is cleared after clicking ok in the msgbox.

I am using the Application.Status as a progress indicator, however it stops working part way through when (Not Responding) displays in title bar.

Any ideas please?

Here's my vba code in my xlsm file:

module1:

Option Explicit
Dim connDatabase As ADODB.Connection
Dim rsDatabase As ADODB.Recordset


Public Sub DataExtract()

On Error GoTo DataExtract_Err

Dim dteStartDate As String
Dim dteEndDate As String
Dim sheetname As String
Dim fieldcount As Integer

' Obtain the start & end dates
dteStartDate = Format(Worksheets("Update").DTPickerStart, "yyyy-mm-dd")
dteEndDate = Format(Worksheets("Update").DTPickerEnd, "yyyy-mm-dd")

' Create new connection & recordset objects.
Set connDatabase = New ADODB.Connection
Set rsDatabase = New ADODB.Recordset

' Open connection to SQL server
Application.StatusBar = "PLEASE WAIT... Attempting to connect to database..."
Application.ScreenUpdating = False
connDatabase.Open "PROVIDER=SQLOLEDB;DATA SOURCE=[IPADDY];INITIAL CATALOG=[DBNAME];UID=[USERID];PWD=[PWD];"

With rsDatabase
    
    ' Assign the Connection object.
    .ActiveConnection = connDatabase
    
    '------------------------[GlobalData]--------------------------------------
    
    sheetname = "GlobalData"
    Application.StatusBar = "PLEASE WAIT... " & sheetname & " ..."
    
    ' Extract the required records.
    '.Open "exec CCC_SLAPerf '" & dteStartDate & "','" & dteEndDate & "';", connDatabase, adOpenStatic
    .Open "select top 5 * from custab;", connDatabase, adOpenStatic

    With Worksheets(sheetname)
    
        ' Clear worksheet
        .Cells.ClearContents
    
        'Populate Header Row with Names
        For fieldcount = 1 To rsDatabase.Fields.Count
            .Cells(1, fieldcount).Value = rsDatabase.Fields(fieldcount - 1).name
        Next fieldcount

        ' Copy records into cell A2.
        .Range("A2").CopyFromRecordset rsDatabase
    
    End With
    
    .Close

    '------------------------[WaitOnCust]--------------------------------------
    
    sheetname = "WaitOnCust"
    Application.StatusBar = "PLEASE WAIT... " & sheetname & " ..."
    
    ' Extract the required records.
    '.Open "exec CCC_WaitOnCust '" & dteStartDate & "','" & dteEndDate & "';", connDatabase, adOpenStatic
    .Open "select top 5 * from ticket;", connDatabase, adOpenStatic

    With Worksheets(sheetname)
    
        ' Clear worksheet
        .Cells.ClearContents
    
        'Populate Header Row with Names
        For fieldcount = 1 To rsDatabase.Fields.Count
            .Cells(1, fieldcount).Value = rsDatabase.Fields(fieldcount - 1).name
        Next fieldcount

        ' Copy records into cell A2.
        .Range("A2").CopyFromRecordset rsDatabase
    
    End With
    
    .Close
    
    '------------------------[2ndTier]-----------------------------------------
    
    sheetname = "2ndTier"
    Application.StatusBar = "PLEASE WAIT... " & sheetname & " ..."
    
    ' Extract the required records.
    '.Open "exec CCC_2ndTier '" & dteStartDate & "','" & dteEndDate & "';", connDatabase, adOpenStatic
    .Open "select top 5 * from account;", connDatabase, adOpenStatic
    Application.StatusBar = "TESTING 3..."

    With Worksheets(sheetname)
    
        ' Clear worksheet
        .Cells.ClearContents

        'Populate Header Row with Names
        For fieldcount = 1 To rsDatabase.Fields.Count
            .Cells(1, fieldcount).Value = rsDatabase.Fields(fieldcount - 1).name
        Next fieldcount

        ' Copy records into cell A2.
        .Range("A2").CopyFromRecordset rsDatabase
    
    End With
    
    .Close

    '--------------------------------------------------------------------------

End With

' Resize columns
'Worksheets("GlobalData").Columns.AutoFit

' Freeze panes below headings
'Worksheets("GlobalData").Select
'Range("A2").Select
'ActiveWindow.FreezePanes = True
'Worksheets("Update").Select
    
' Set 'last updated' date
Application.StatusBar = False
Worksheets("Update").Range("B16").Value = Date

' Display message box when complete
MsgBox "Update data complete.", vbInformation
    
    
'Exit Handler
DataExtract_Exit:
    On Error Resume Next
    Application.StatusBar = False
    Application.ScreenUpdating = True
    rsDatabase.Close
    connDatabase.Close
    Set rsDatabase = Nothing
    Set connDatabase = Nothing
    Exit Sub

'Error Handler
DataExtract_Err:
    Application.StatusBar = "Error occurred..."
    MsgBox Err.Source & ", ERROR# " & Err.Number & ", LINE# " & Erl() & ", HelpContext: " & Err.HelpContext _
        & vbCrLf & vbCrLf & Err.Description _
        , vbCritical, "DataExtract Error!"
    Resume DataExtract_Exit

End Sub


Public Sub FixDTPickers()

On Error GoTo FixDTPickers_Err

' A workaround for the DTPicker's not displaying correctly per mubashiraziz in
' http://www.mrexcel.com/forum/showthread.php?t=70813&highlight=DTPicker
Application.ScreenUpdating = False
ActiveWindow.ScrollRow = 2
ActiveWindow.ScrollRow = 1
Application.ScreenUpdating = True

'Exit Handler
FixDTPickers_Exit:
    On Error Resume Next
    Application.ScreenUpdating = True
    Exit Sub

'Error Handler
FixDTPickers_Err:
    MsgBox Err.Source & ", ERROR# " & Err.Number & ", LINE# " & Erl() & ", HelpContext: " & Err.HelpContext _
        & vbCrLf & vbCrLf & Err.Description _
        , vbCritical, "FixDTPickers Error!"
    Resume FixDTPickers_Exit

End Sub

Sheet1:

Private Sub Worksheet_Activate()

Call FixDTPickers

End Sub

ThisWorkbook:

Private Sub Workbook_Open()

Call FixDTPickers

End Sub