Solved: VBA To Access taking too long

[White_Nova]

Hi All

Wonder if you can have a look at this for me.
I have VBA code (Below) that writes to an access database...
When i try and use the update function it takes way too long to run through the code...
Please let me know what im doing wrong...

Sub MultiWeeks()


Dim SQL As String
Dim filenm As String

filenm = (ActiveWorkbook.Path & "\Store.mdb")

Dim conn As New ADODB.Connection
Dim rst As ADODB.Recordset
Dim rs As ADODB.Recordset


Set conn = New ADODB.Connection
Set rst = New ADODB.Recordset
Set rs = New ADODB.Recordset

rst.CursorLocation = adUseClient
rst.CursorType = adOpenStatic
rst.LockType = adLockBatchOptimistic

conn.ConnectionString = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source= " & filenm & ";Persist Security Info=False"
conn.Open


Sheets("Multi Weeks").Select



If Range("E11").Value <> "" Then

r = 28 'Starts at row specified
Do While (Range("A" & r).Formula) <> ""


rst.ActiveConnection = conn
rst.Open "Update [Store1] " & _
"set [Club]='" & Range("A" & r).Value & "',[Dev]='" & Range("B" & r).Value & "',[Res]='" & Range("C" & r).Value & _
"',[Unit]='" & Range("D" & r).Value & _
"',[Mod]='" & Range("E" & r).Value & _
"',[Size]='" & Range("F" & r).Value & _
"',[RCI]='" & Range("G" & r).Value & _
"',[Sea]='" & Range("H" & r).Value & _
"',[Wee]='" & Range("I" & r).Value & _
"', [TranSt]='" & Range("J" & r).Value & _
"', [ShaCertno]='" & Range("K" & r).Value & _
"', [StocSource]='" & Range("L" & r).Value & _
"', [StartDate]='" & Range("M" & r).Value & _
"', [FinDate]='" & Range("N" & r).Value & _
"', [WeekType]='" & Range("O" & r).Value & _
"', [ArrDate]='" & Range("P" & r).Value & _
"', [Other2007]='" & Range("AC" & r).Value & "', [paidother2007]= '" & Range("AD" & r).Value & "', [RentBud2008]='" & Range("AU" & r).Value & "', [RentPaid2008]='" & Range("AV" & r).Value & "', [PaidRent2008]='" & Range("AW" & r).Value & "', [RentInvNo2008]='" & Range("AX" & r).Value & "', [OustRent2008]='" & Range("AY" & r).Value & "', [Uni1]='" & Range("AZ" & r).Value & "', [RentBud2007]='" & Range("AE" & r).Value & "', [RentPaid2007]='" & Range("AF" & r).Value & "', [PaidRent2007]='" & Range("AG" & r).Value & "', [RentinvNo2007]='" & Range("AH" & r).Value & "', [OustRent2007]='" & Range("AI" & r).Value & "', [Levy2006]='" & Range("AJ" & r).Value & "', [ResCode]='" & Range("AK" & r).Value & "', [LevyBud2008]='" & Range("AL" & r).Value & "', [LevyPaid2008]='" & Range("AM" & r).Value & "', [PaidLevy2008]='" & Range("AN" & r).Value & "', [InvNo2008]='" & Range("AO" & r).Value & "', [OustLevy2008]='" & Range("AP" & r).Value & "', [SpecLevy2008]='" & Range("AQ" & r).Value & _
"', [DepDate]='" & Range("Q" & r).Value & _
"', [OrigCurrency]='" & Range("R" & r).Value & _
"', [StocAgNo]='" & Range("S" & r).Value & "', [PaidSpecLevy2008]='" & Range("AR" & r).Value & "', [Other2008]='" & Range("AS" & r).Value & "', [PaidOther2008]='" & Range("AT" & r).Value & _
"', [ManFee]= '" & Range("T" & r).Value & "', [MemFee]='" & Range("U" & r).Value & _
"', [LevyBud2007]='" & Range("V" & r).Value & _
"', [LevyPaid2007]='" & Range("W" & r).Value & "', [PaidLevy2007]='" & Range("X" & r).Value & "' & [InvNo2007]='" & Range("Y" & r).Value & "' & [OustLevy2007]='" & Range("Z" & r).Value & "', [SpecLevy2007]='" & Range("AA" & r).Value & "', [PaidSpecLevy2007]='" & Range("AB" & r).Value & _
"', [ResortCodeID]='" & Range("BB" & r).Value & _
"', [ClubID]='" & Range("BA" & r).Value & "', [Type]='" & Range("BC" & r).Value & "', [Sur]='" & Range("BD" & r).Value & "', [QVCNum]='" & Range("BE" & r).Value & "', [OcDate]='" & Range("BF" & r).Value & _
"' WHERE [Store1].[Uni1]='" & Range("AZ" & r).Value & "'"




r = r + 1 ' next row

Loop



End If

End Sub

[White_Nova]

Just an add in, if there are 2 or 3 records that need updating its pretty quick...
its when there is more than say 100 that it becomes a problem...

[Bob Phillips]

Firts thought.

Sort the data so those blanks are at the end, calculate the last line of real data, then just load from 28 to there. That is, don't process those that you do not want.

[White_Nova]

agreed, however there are no blanks and secondly ammendments can be made to any of the records from 1 to 10 000 so updating them all is the only option...

[White_Nova]

Here it is for anyone who is interested:

Sub MultiWeeks()


Dim SQL As String
Dim filenm As String
Dim dbmain As ADODB.Connection
Dim rcset As ADODB.Recordset
Dim sqlstr As String
Dim dbPath As String
Dim find As String
Dim mkt As String

filenm = (ActiveWorkbook.Path & "\Store.mdb")

Dim conn As New ADODB.Connection
Dim rst As ADODB.Recordset
Dim rs As ADODB.Recordset


Set conn = New ADODB.Connection
Set rst = New ADODB.Recordset
Set rs = New ADODB.Recordset

rst.CursorLocation = adUseClient
rst.CursorType = adOpenStatic
rst.LockType = adLockBatchOptimistic

dbPath = (ActiveWorkbook.Path & "\Store.mdb")

Set dbmain = New ADODB.Connection

dbmain.Open "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & dbPath

conn.ConnectionString = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source= " & filenm & ";Persist Security Info=False"
conn.Open


Sheets("Multi Weeks").Select



If Range("E11").Value <> "" Then

r = 28 'Starts at row specified
Do While (Range("A" & r).Formula) <> ""

sqlstr = "Update [Store1] " & _
"set [Club]='" & Range("A" & r).Value & "',[Dev]='" & Range("B" & r).Value & "',[Res]='" & Range("C" & r).Value & _
"',[Unit]='" & Range("D" & r).Value & _
"',[Mod]='" & Range("E" & r).Value & _
"',[Size]='" & Range("F" & r).Value & _
"',[RCI]='" & Range("G" & r).Value & _
"',[Sea]='" & Range("H" & r).Value & _
"',[Wee]='" & Range("I" & r).Value & _
"', [TranSt]='" & Range("J" & r).Value & _
"', [ShaCertno]='" & Range("K" & r).Value & _
"', [StocSource]='" & Range("L" & r).Value & _
"', [StartDate]='" & Range("M" & r).Value & _
"', [FinDate]='" & Range("N" & r).Value & _
"', [WeekType]='" & Range("O" & r).Value & _
"', [ArrDate]='" & Range("P" & r).Value & _
"', [Other2007]='" & Range("AC" & r).Value & "', [paidother2007]= '" & Range("AD" & r).Value & "', [RentBud2008]='" & Range("AU" & r).Value & "', [RentPaid2008]='" & Range("AV" & r).Value & "', [PaidRent2008]='" & Range("AW" & r).Value & "', [RentInvNo2008]='" & Range("AX" & r).Value & "', [OustRent2008]='" & Range("AY" & r).Value & "', [Uni1]='" & Range("AZ" & r).Value & "', [RentBud2007]='" & Range("AE" & r).Value & "', [RentPaid2007]='" & Range("AF" & r).Value & "', [PaidRent2007]='" & Range("AG" & r).Value & "', [RentinvNo2007]='" & Range("AH" & r).Value & "', [OustRent2007]='" & Range("AI" & r).Value & "', [Levy2006]='" & Range("AJ" & r).Value & "', [ResCode]='" & Range("AK" & r).Value & "', [LevyBud2008]='" & Range("AL" & r).Value & "', [LevyPaid2008]='" & Range("AM" & r).Value & "', [PaidLevy2008]='" & Range("AN" & r).Value & "', [InvNo2008]='" & Range("AO" & r).Value & "', [OustLevy2008]='" & Range("AP" & r).Value & "', [SpecLevy2008]='" & Range("AQ" & r).Value & _
"', [DepDate]='" & Range("Q" & r).Value & _
"', [OrigCurrency]='" & Range("R" & r).Value & _
"', [StocAgNo]='" & Range("S" & r).Value & "', [PaidSpecLevy2008]='" & Range("AR" & r).Value & "', [Other2008]='" & Range("AS" & r).Value & "', [PaidOther2008]='" & Range("AT" & r).Value & _
"', [ManFee]= '" & Range("T" & r).Value & "', [MemFee]='" & Range("U" & r).Value & _
"', [LevyBud2007]='" & Range("V" & r).Value & _
"', [LevyPaid2007]='" & Range("W" & r).Value & "', [PaidLevy2007]='" & Range("X" & r).Value & "' & [InvNo2007]='" & Range("Y" & r).Value & "' & [OustLevy2007]='" & Range("Z" & r).Value & "', [SpecLevy2007]='" & Range("AA" & r).Value & "', [PaidSpecLevy2007]='" & Range("AB" & r).Value & _
"', [ResortCodeID]='" & Range("BB" & r).Value & _
"', [ClubID]='" & Range("BA" & r).Value & "', [Type]='" & Range("BC" & r).Value & "', [Sur]='" & Range("BD" & r).Value & "', [QVCNum]='" & Range("BE" & r).Value & "', [OcDate]='" & Range("BF" & r).Value & _
"' WHERE [Store1].[Uni1]='" & Range("AZ" & r).Value & "'"




r = r + 1 ' next row

Loop



End If

End Sub

Using a SQL statement to update the date takes a matter os seconds.
I updated 10 000 records in +- 10 seconds...

[Bob Phillips]

agreed, however there are no blanks and secondly ammendments can be made to any of the records from 1 to 10 000 so updating them all is the only option...

So why are you testing for blanks - that takes time.

[White_Nova]

this does not test for blanks, there are no blanks, it just writes the data as is to access.

[Bob Phillips]

this does not test for blanks, there are no blanks, it just writes the data as is to access.




If Range("E11").Value <> "" Then

[White_Nova]

That range specified there is a criteria expression...
It is never blank, just a precuasion for stupid users...