JONvdHeyden
06-18-2009, 11:05 PM
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
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