SOLVED: Delete row with Autofilter takes ages after ADO code

[JONvdHeyden]

Hello All

First off this is a cross post, see: http://www.mrexcel.com/forum/showthread.php?t=397226

I will post here any solutions I collect from that post, but I don't think a response there is likely...

I have 3 subs:
Sub1 uses plain SQL to select data from a sheet and populate various other sheets (using ADO).

Sub2 deletes rows after a range has been filtered.

Sub3 runs Sub1 and then Sub2.

This was originally in a single sub so now it looks more daunting than it actually is.

Sub1 runs fine and it is incredibly quick.
Sub2 takes ages if run directly after Sub1, but it is also incredibly quick provided I run it first (which I must not do)...

Does anybody know why Sub1 will impact the performance of Sub2?

Thanks for help.

Sub1
Option Explicit
Dim arrCrit()
Dim lngCalc As Long, lngItem As Long
Dim wksSupplier As Worksheet

Sub MakeStatements()
Dim lngLastRow As Long
With Sheets("Overall")
lngLastRow = .Range("A" & Rows.Count).End(xlUp).Row
Names.Add "rngData", .Range("A6:I" & lngLastRow)
End With
For Each wksSupplier In Worksheets
If wksSupplier.Name <> "Overall" And wksSupplier.Name <> "Archive" Then
ReDim Preserve arrCrit(lngItem)
arrCrit(lngItem) = wksSupplier.Name
lngItem = lngItem + 1
End If
Next wksSupplier
Dim Connection As ADODB.Connection
Set Connection = New ADODB.Connection
Dim strConnection As String, strSQL As String, strCrit As String
Dim recData As ADODB.Recordset
Set recData = New ADODB.Recordset
Dim lngCalc As Long
strConnection = "Provider=Microsoft.Jet.OLEDB.4.0;" & _
"Data Source=" & ActiveWorkbook.FullName & _
"; Extended Properties=Excel 8.0;"

With Connection
.ConnectionString = strConnection
.Open
End With

strSQL = "SELECT * FROM [rngData] WHERE Not [Paid] Is Null"
Call recData.Open(strSQL, strConnection, adOpenForwardOnly, adLockReadOnly, adCmdText)
Call Sheets("Archive").Range("A7").CopyFromRecordset(recData)
recData.Close

For lngItem = 0 To UBound(arrCrit)
strCrit = arrCrit(lngItem)
strSQL = "SELECT * FROM [rngData] WHERE [Supplier] = """ & strCrit & """ AND [Paid] Is Null"
Call recData.Open(strSQL, strConnection, adOpenForwardOnly, adLockReadOnly, adCmdText)
Call Sheets(strCrit).Range("A7").CopyFromRecordset(recData)
recData.Close
Next lngItem

Connection.Close
Set recData = Nothing
Set Connection = Nothing
End Sub

Sub2
Sub DeleteData()
With Application
lngCalc = .Calculation
.Calculation = xlManual
.ScreenUpdating = False
End With

For Each wksSupplier In Worksheets
If wksSupplier.Name <> "Overall" And wksSupplier.Name <> "Archive" Then
ReDim Preserve arrCrit(lngItem)
arrCrit(lngItem) = wksSupplier.Name
lngItem = lngItem + 1
End If
Next wksSupplier

'// delete data here here - ISAM does not suppoort deletion with plain SQL //
With Sheets("Overall")
.AutoFilterMode = False
On Error Resume Next
For lngItem = 0 To UBound(arrCrit)
With .Range("rngData")
.AutoFilter Field:=1, Criteria1:=arrCrit(lngItem)
.Offset(1).EntireRow.Delete
.AutoFilter
End With
Next lngItem
On Error GoTo 0
End With

With Application
.Calculation = lngCalc
.ScreenUpdating = True
End With
End Sub

Sub3
Sub LoadandClear()
Call MakeStatements
Call DeleteData
MsgBox prompt:="Completed", Buttons:=vbInformation
End Sub

[p45cal]

try adding
ReDim arrCrit(0)
and setting lngItem back to 0
early in each Sub

or don't have these as global variables.
(On my machine this array doubles in size each time each sub is run, so although the array contains valid sheet names, it contains them multiple times and so any loop involving it will be repeating itself unnecessarily.)

[Jan Karel Pieterse]

Silly maybe, but what if you call the second sub using the ontime method rather than directly?

[JONvdHeyden]

Hi p45Cal

That is a valid point but it still doesn't make any significant improvement I'm afraid.

Hi Jan

I created a start_timer and a stop_timer. The start timer is triggered at the end of 'MakeStatement' and a applies a 5 second delay (not sure if you meant to include a delay). It will trigger 'DeleteData'.

The stop_timer is called at the first line in DeleteData.

Again I didn't notice any improvement unfortunately. But may I ask what is the rationale for this?

Thank you.

[Bob Phillips]

Jon,

Doing what Jan Karel suggested sometimes improves matters because it 'breaks links'. Things are not always completed in the background when another action starts, and it can cause unexpected results. By using Ontime it allows a complete separation of tasks.

We had a problem with CFPlus whereby we rebuild the menus/toolbars throughout, and they often failed to rebuild. By addin Ontime to invoke that rebuild, every cleared down and the toolbars rebuilt. The 5 secs is not necessary, we fired Ontime with just Now as the runtime, it was the separation not the delay that helped.

[JONvdHeyden]

That's handy to know, thank you Bob.

I have an answer to this specific problem. It turns out that because I was connecting to the active workbook a memory leak occurs. Microsoft recommends making a copy of the workbook and then query that instead.

http://support.microsoft.com/kb/319998 (http://support.microsoft.com/kb/319998)

So I have ended up with this:

Option Explicit
Dim wksSupplier As Worksheet

Sub MakeStatements()
Dim lngLastRow As Long, lngItem As Long
Dim arrCrit()
With Sheets("Overall")
lngLastRow = .Range("A" & Rows.Count).End(xlUp).Row
Names.Add "rngData", .Range("A6:I" & lngLastRow)
End With
For Each wksSupplier In Worksheets
If wksSupplier.Name <> "Overall" And wksSupplier.Name <> "Archive" Then
ReDim Preserve arrCrit(lngItem)
arrCrit(lngItem) = wksSupplier.Name
lngItem = lngItem + 1
End If
Next wksSupplier
Dim Connection As ADODB.Connection
Set Connection = New ADODB.Connection
Dim strConnection As String, strSQL As String, strCrit As String
Dim recData As ADODB.Recordset
Set recData = New ADODB.Recordset
ActiveWorkbook.SaveCopyAs Environ$("temp") & "\temp.xls"
strConnection = "Provider=Microsoft.Jet.OLEDB.4.0;" & _
"Data Source=" & Environ$("temp") & "\temp.xls" & _
"; Extended Properties=Excel 8.0;"

With Connection
.ConnectionString = strConnection
.Open
End With

strSQL = "SELECT * FROM [rngData] WHERE Not [Paid] Is Null"
Call recData.Open(strSQL, strConnection, adOpenForwardOnly, adLockReadOnly, adCmdText)
Call Sheets("Archive").Range("A7").CopyFromRecordset(recData)
recData.Close

For lngItem = 0 To UBound(arrCrit)
strCrit = arrCrit(lngItem)
strSQL = "SELECT * FROM [rngData] WHERE [Supplier] = """ & strCrit & """ AND [Paid] Is Null"
Call recData.Open(strSQL, strConnection, adOpenForwardOnly, adLockReadOnly, adCmdText)
Call Sheets(strCrit).Range("A7").CopyFromRecordset(recData)
recData.Close
Next lngItem

Connection.Close
Set recData = Nothing
Set Connection = Nothing
Kill Environ$("temp") & "\temp.xls"
End Sub

Sub DeleteData()
Dim arrCrit()
Dim lngCalc As Long, lngItem As Long
With Application
lngCalc = .Calculation
.Calculation = xlManual
.ScreenUpdating = False
End With

For Each wksSupplier In Worksheets
If wksSupplier.Name <> "Overall" And wksSupplier.Name <> "Archive" Then
ReDim Preserve arrCrit(lngItem)
arrCrit(lngItem) = wksSupplier.Name
lngItem = lngItem + 1
End If
Next wksSupplier

'// delete data here here - ISAM does not suppoort deletion with plain SQL //
With Sheets("Overall")
.AutoFilterMode = False
On Error Resume Next
For lngItem = 0 To UBound(arrCrit)
With .Range("rngData")
.AutoFilter Field:=1, Criteria1:=arrCrit(lngItem)
.Offset(1).EntireRow.Delete
.AutoFilter
End With
Next lngItem
On Error GoTo 0
End With

With Application
.Calculation = lngCalc
.ScreenUpdating = True
End With
End Sub