Is there a better way?

J

JT

I'm using the following code to import an Excel file into an Access database.
Some of the cost center users have complained that it can take 30 minutes or
more to import the data (26,000 lines in a spreadsheet).

Is there a better way to code this so it runs quicker or is the length of
time dependant on their network connection? Thanks for the help......

~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

Application.DisplayAlerts = False

Set AppAcc = New Access.Application
AppAcc.Visible = False
AppAcc.OpenCurrentDatabase vDB

AppAcc.DoCmd.OpenQuery "Clear_Data_Prior" AppAcc.DoCmd.OpenQuery
"Copy_To_Prior_Data"
AppAcc.DoCmd.OpenQuery "Clear_Data_Current"

AppAcc.DoCmd.TransferSpreadsheet acImport,
acspreadsheetTypeExcel5,"Data_Current", vData, True

AppAcc.DoCmd.OpenQuery "Update_Notes_From_Data_Prior"

AppAcc.DoCmd.OpenQuery "Convert_Dates"

AppAcc.DoCmd.OpenQuery "Convert_Dates_2"

AppAcc.DoCmd.OpenQuery "Delete_City_Area_Info"

vSQL = "INSERT INTO CITY_AREA ([GROUP],[BRANCH],[CITY],[AREA]) In '" & vDB &
"' SELECT [GROUP],[BRANCH],[CITY],[AREA] FROM Admin_officesAll IN
'\\myfs00\Corporate\AM\Trans.mdb' WHERE [GROUP] = '" & mygroup & "'"

Set Recordset = New ADODB.Recordset

Call Recordset.Open(vSQL, ConnectionString2, adOpenForwardOnly,
adLockReadOnly, CommandTypeEnum.adCmdText)

Set Recordset = Nothing

vSQL = "UPDATE Data_Current INNER JOIN CITY_AREA ON (Data_Current.BR =
CITY_AREA.BRANCH) AND (Data_Current.GP = CITY_AREA.GROUP) SET
Data_Current.CITY = CITY_AREA!CITY, Data_Current.AREA = CITY_AREA!AREA"

Set Recordset = New ADODB.Recordset

Call Recordset.Open(vSQL, ConnectionString3, adOpenForwardOnly,
adLockReadOnly, CommandTypeEnum.adCmdText)

Set Recordset = Nothing

AppAcc.Visible = True
AppAcc.Quit acQuitSaveAll

Application.DisplayAlerts = True
Set AppAcc = Nothing
 
J

JLatham

It's been my experience in the (distant) past that dealing with this type of
thing over a WAN can result in long wait times for completion. I worked on a
project for AT&T back in their SBC Corp days that we ended up basically
abandoning because of the excessive update times involved - the process
actually worked, but the product went mostly unused because of the delays
involved.

For faster processing they might consider upgrading to a more powerful
database application than Access (which really is still considered a
'personal' database rather than an enterprise strength product). Perhaps
consider going all the way to Microsoft SQL Server, or their 'desktop'
version of it, or Visual FoxPro - or even to the free, open source MySQL.
All are ODBC compliant, so you can still communicate with them from Excel.

One alternative to consider is to simply create the 'dataset' you need to
import into Access as an Excel worksheet, save that worksheet into a separate
workbook, send the workbook to them and let them import the data at their
end? They could set up an automated import process in Access at their end to
import the file and that might happen quicker than the way you're doing it
now.

JT said:
I'm using the following code to import an Excel file into an Access database.
Some of the cost center users have complained that it can take 30 minutes or
more to import the data (26,000 lines in a spreadsheet).

Is there a better way to code this so it runs quicker or is the length of
time dependant on their network connection? Thanks for the help......

~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

Application.DisplayAlerts = False

Set AppAcc = New Access.Application
AppAcc.Visible = False
AppAcc.OpenCurrentDatabase vDB

AppAcc.DoCmd.OpenQuery "Clear_Data_Prior" AppAcc.DoCmd.OpenQuery
"Copy_To_Prior_Data"
AppAcc.DoCmd.OpenQuery "Clear_Data_Current"

AppAcc.DoCmd.TransferSpreadsheet acImport,
acspreadsheetTypeExcel5,"Data_Current", vData, True

AppAcc.DoCmd.OpenQuery "Update_Notes_From_Data_Prior"

AppAcc.DoCmd.OpenQuery "Convert_Dates"

AppAcc.DoCmd.OpenQuery "Convert_Dates_2"

AppAcc.DoCmd.OpenQuery "Delete_City_Area_Info"

vSQL = "INSERT INTO CITY_AREA ([GROUP],[BRANCH],[CITY],[AREA]) In '" & vDB &
"' SELECT [GROUP],[BRANCH],[CITY],[AREA] FROM Admin_officesAll IN
'\\myfs00\Corporate\AM\Trans.mdb' WHERE [GROUP] = '" & mygroup & "'"

Set Recordset = New ADODB.Recordset

Call Recordset.Open(vSQL, ConnectionString2, adOpenForwardOnly,
adLockReadOnly, CommandTypeEnum.adCmdText)

Set Recordset = Nothing

vSQL = "UPDATE Data_Current INNER JOIN CITY_AREA ON (Data_Current.BR =
CITY_AREA.BRANCH) AND (Data_Current.GP = CITY_AREA.GROUP) SET
Data_Current.CITY = CITY_AREA!CITY, Data_Current.AREA = CITY_AREA!AREA"

Set Recordset = New ADODB.Recordset

Call Recordset.Open(vSQL, ConnectionString3, adOpenForwardOnly,
adLockReadOnly, CommandTypeEnum.adCmdText)

Set Recordset = Nothing

AppAcc.Visible = True
AppAcc.Quit acQuitSaveAll

Application.DisplayAlerts = True
Set AppAcc = Nothing
 
G

Greg Glynn

JT,

I'm doing something similar, but have taken a different approach.

I'm importing 15000 lines frmo Excel into an Access DB, but have not
remotely opened Access as you have with

Application.DisplayAlerts = False
Set AppAcc = New Access.Application
AppAcc.Visible = False
AppAcc.OpenCurrentDatabase vDB
AppAcc.DoCmd.OpenQuery "Clear_Data_Prior"
AppAcc.DoCmd.OpenQuery "Copy_To_Prior_Data"
AppAcc.DoCmd.OpenQuery "Clear_Data_Current"
AppAcc.DoCmd.TransferSpreadsheet acImport,
acspreadsheetTypeExcel5,"Data_Current", vData, True
AppAcc.DoCmd.OpenQuery "Update_Notes_From_Data_Prior"
AppAcc.DoCmd.OpenQuery "Convert_Dates"
AppAcc.DoCmd.OpenQuery "Convert_Dates_2"
AppAcc.DoCmd.OpenQuery "Delete_City_Area_Info

Instead, I use ADO to open the Databases, queries, tables and records
sets natively from excel and use:
For Each Line in Origin
with rsRecords
.add
.Update
End With
Next Line

With checking for existing records (.findfirst) etc, it takes about 4
mins to import 15000 records. You might consider creating an UPDATE
QUERY in ACCESS an using that to add records.

Here's a sample of my code:

Sub ProcessSSRServerList()

On Error GoTo ErrHandler

Dim dbBackupRecord As DAO.Database
Dim qdfActiveServers As DAO.QueryDef
Dim qdfClusterServers As DAO.QueryDef
Dim tbClusterCheck As DAO.QueryDef
Dim rsServerList As DAO.Recordset
Dim rsClusterList As DAO.Recordset
Dim rsBackups As DAO.Recordset
Dim rsUBItable As DAO.Recordset
Dim rsIncidentLog As DAO.Recordset

' Get the MS ACCESS database name from the spreadsheet
DatabaseName =
Workbooks(wbName).Sheets(shName).Range("DatabaseLocation")

' Define the RecordSets
Set dbBackupRecord = OpenDatabase(DatabaseName)
Set qdfClusterServers =
dbBackupRecord.QueryDefs("ActiveClusterServers")
Set qdfActiveServers = dbBackupRecord.QueryDefs("ActiveServers")
Set rsBackups =
dbBackupRecord.QueryDefs("ActivityPlusUBI").OpenRecordset(dbOpenDynaset)
Set rsServerList = qdfActiveServers.OpenRecordset(dbReadOnly)
Set rsClusterList = qdfClusterServers.OpenRecordset(dbReadOnly)
Set rsUBItable =
dbBackupRecord.TableDefs("UBI").OpenRecordset(dbOpenDynaset)
Set rsIncidentLog =
dbBackupRecord.TableDefs("IncidentLog").OpenRecordset(dbOpenDynaset)

'Count the number of servers in the ServerList
With rsServerList
If .EOF Then
ServerCount = 0
Else
.MoveLast
ServerCount = .RecordCount
.MoveFirst
End If
.Close
End With

' Get the next blank line on the Audit Log
AuditLine = Workbooks(wbName).Sheets("Backup Audit").Cells(65500,
1).End(xlUp).Row

' Reopen the Server
Set rsServerList =
qdfActiveServers.OpenRecordset(dbOpenForwardOnly)

' Start the Processing Loop
If Not rsServerList.BOF Then
With rsServerList
Do Until .EOF Or SingleShot = True
If MajorFunctions.ServerSelector.Value <> "ALL
SERVERS" Then
SingleShot = True
Do Until .Fields("ServerName") =
MajorFunctions.ServerSelector.Value
.MoveNext
Loop
End If

' Record the Name of the server to map to
MyClient = .Fields("ServerName")

' Determine if it is a Cluster Server by comparing the
Serverlist item against the ClusterList
With rsClusterList
.MoveFirst
.FindFirst "ServerName = '" & MyClient & "'"
If Not .NoMatch Then
IsCluster = True
MyClusterText = " [Cluster] "
Else
IsCluster = False
MyClusterText = ""
End If
End With

MyDescription = .Fields("Description")
MyCity = .Fields("City")

Application.StatusBar = "Step " &
rsServerList.RecordCount & "/" & ServerCount & " Trying to Map to " &
MyClusterText & .Fields("ServerName") & " - " & MyCity

F = LCase(Dir("\\" & MyClient & "\apps\bkupexec\log\0000*.*"))

DoEvents

'Loop through all the files in that directory which match the
target mask (above)
Do While Len(F) > 0
'Set FNAME as the full Directory and File Name
If InStr(F, "exporting") = 0 And _
InStr(F, "copy") = 0 And _
InStr(F, "restore") = 0 And _
InStr(F, "inventory") = 0 And _
InStr(F, ".log") = 0 And _
InStr(F, ".idx") = 0 And _
InStr(F, ".dat") = 0 Then

FName = "\\" & MyClient & "\apps\bkupexec\log\" & F

'Examine the files that are within the ReviewDays period
'Change this later to pickup is the record already exists
(meaning no point reprocessing it)
MyFileDate = FileDateTime(FName)
If MyFileDate >= Now() - MajorFunctions.LogHistory.Value Then

Application.StatusBar = "Step " & rsServerList.RecordCount &
"/" & ServerCount & ": Processing: " & MyClusterText & FName
'***
'Log Processor Start
'<<<<<
WholeLine = ""
Open FName For Input Access Read As #2
On Error Resume Next
While Not EOF(2) Or InStr(WholeLine, "Backup operation
ended:") > 0

' Preface Processing
Do 'Until Instr(WholeLine, "Job server:") > 0
Line Input #2, WholeLine
Loop Until InStr(WholeLine, "Job server:") > 0 Or EOF(2)

' Store the {RemoteServerName}
RemoteServerName = Trim(Mid(WholeLine, InStr(WholeLine, ": ")
+ 2, 99))

' Read a whole line And Loop until "Backup method:"
Do
Line Input #2, WholeLine
Loop Until InStr(WholeLine, "Backup method:") > 0 Or EOF(2)

' Store the BackupType as {MySchedule}
MySchedule = Trim(Mid(WholeLine, InStr(WholeLine, ":") + 2,
20))

' *** Begin Backup Set Processing Loop
' Read a whole line and Loop until "Backup set started:" or
"Backup Operation Ended:"
Do While InStr(WholeLine, "Backup operation ended:") = 0 Or
EOF(2) 'Therefore A New Set has started
Do
Line Input #2, WholeLine
Loop Until InStr(WholeLine, "Backup set started:") > 0 _
Or InStr(WholeLine, "Backup operation ended:")
Or EOF(2)
If InStr(WholeLine, "Backup operation ended:") > 0 Or
EOF(2) Then Exit Do
'*** Backup Set Processing
' MyFindString = "Backup of " & RemoteServerName &
".NetWare File System/" & RemoteServerName & "/"
MyFindString = "Backup of "
Do
Line Input #2, WholeLine
Loop Until InStr(WholeLine, MyFindString) = 8 Or
EOF(2) 'Find "Backup of" at character 8'

' Extract the Volume Name {MyPolicy}
MyPolicy = Trim(Mid(WholeLine, InStrRev(WholeLine,
"/") + 1, 99))
If MyPolicy <> "Server Specific Info:" Then
ErrCount = 0
WrnCount = 0
Do Until InStr(WholeLine, "Backup set ended:") > 0
Or EOF(2)
Line Input #2, WholeLine
If Mid(WholeLine, 3, 3) = "ERR" Then ErrCount
= ErrCount + 1
If Mid(WholeLine, 3, 3) = "WRN" Then WrnCount
= WrnCount + 1
If InStr(WholeLine, "Total bytes:") > 0 Then
If Len(WholeLine) > 29 And InStr(29,
WholeLine, " ") > 0 Then
MyBytes = Trim(Mid(WholeLine, 29,
InStr(30, WholeLine, " ") - 29))
Else
MyBytes = 0
End If

End If
Loop 'Until InStr(WholeLine, "Backup Set Ended:")
MyStatus = 0
If WrnCount > 1 Then MyStatus = 1
If ErrCount > 1 Then MyStatus = 2

' UBI Processing
If MyPolicy <> "" And MySchedule <> "" And
MyClient <> "" And Not EOF(2) Then
MyFindString = "Policy = '" & MyPolicy & _
"' AND Schedule = '" & UCase(MySchedule) &
_
"' AND Client = '" & MyClient & _
"' AND StartTime = #" & MyFileDate & "#"

With rsBackups
.FindFirst
MyFindString
If Not .NoMatch Then
' This Backup Record
Exists - Skip to next
Else
' Check to see if a New
UBI has been found - If so, Add it to the UBI Table
MyUBILookup =
"Policy = '" & MyPolicy & "' AND Schedule = 'DAILY_" &
UCase(MySchedule) & "' AND Client = '" & MyClient & "'"
With rsUBItable
.FindFirst
MyUBILookup
If .NoMatch Then
' Add the new
Unique UBI to the UBI Dataset
.AddNew
MyUBI =
rsUBItable.Fields("UBI") 'Save this value for the Activity File
.Fields("Policy")
= MyPolicy
.Fields("Schedule")
= "DAILY_" & UCase(MySchedule)
.Fields("Client")
= MyClient
.Update


rsIncidentLog.AddNew

rsIncidentLog.Fields("Client") = MyClient

rsIncidentLog.Fields("Policy") = MyPolicy

rsIncidentLog.Fields("Schedule") = MySchedule

rsIncidentLog.Fields("IncidentTime") = Now()

rsIncidentLog.Fields("IncidentText") = "New UBI found"

rsIncidentLog.Update

Else
MyUBI =
rsUBItable.Fields("UBI")
End If
End With 'rsUBItable
' A New Backup Record
exists in the Spreadsheet - Add it to the Database
.AddNew
.Fields("UBI") = MyUBI
.Fields("Status") =
MyStatus
.Fields("StartTime") =
MyFileDate
.Fields("EndTime") =
Null
.Fields("Kilobytes") =
MyBytes
.Fields("State") =
"Done"
.Fields("Type") =
"Backup"
.Fields("JOBID") =
"BackupEXEC"
.Fields("ActiveStart")
= Null
.Update
End If 'Not .NoMatch
End With 'rsBackups
End If 'MyPolicy <> "" And
MySchedule <> "" And MyClient <> And Not EOF(2)""

' UBI Processing finsished
End If
Line Input #2, WholeLine
Loop 'While Instr(Wholeline, "Backup
operation ended:") = 0
Line Input #2, WholeLine
Wend 'While Not EOF(2)
Close #2
' '*** End Log Processor
DoEvents
On Error GoTo ErrHandler
End If 'FileDate >10
End If 'Filename <> bad extentions
F = Dir()
Loop 'Do While Len(F)>0
.MoveNext
Loop
End With
End If

'Next x 'Loop again and run the through the other server list

Application.ScreenUpdating = True

Application.StatusBar = "Start: " & Format(MyStartTimer,
"hh:mm:ss") & " Finish: " & Format(Now(), "hh:mm:ss") & "
Processing Complete." ' Processed " & MyRecordCount & " records. "

Exit Sub

ErrHandler:

Select Case Err
Case 52

Close #2

rsIncidentLog.AddNew
rsIncidentLog.Fields("Client") = MyClient
rsIncidentLog.Fields("IncidentTime") = Now()
rsIncidentLog.Fields("IncidentText") = "Problem
Connecting"
rsIncidentLog.Update

Resume Next

Case Else
MsgBox Err & " " & Error(Err)
Close #2

rsIncidentLog.Close
rsUBItable.Close
rsServerList.Close
rsBackups.Close
rsClusterList.Close
qdfActiveServers.Close
qdfClusterServers.Close
dbBackupRecord.Close

Exit Sub

End Select

rsIncidentLog.Close
rsUBItable.Close
rsServerList.Close
rsBackups.Close
rsClusterList.Close
qdfActiveServers.Close
qdfClusterServers.Close
dbBackupRecord.Close

End Sub
 

Ask a Question

Want to reply to this thread or ask your own question?

You'll need to choose a username for the site, which only take a couple of moments. After that, you can post your question and our members will help you out.

Ask a Question

Top