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
