Thread: VBA Hangs While Copying to Access DB using ADO

Hello,

I'm trying to import data from Excel into an Access 2007 DB using ADO. Sometimes the data will create a new record, other times it will be updating an existing record, based on a unique ID to each row in Excel. When updating, it proceeds quickly. However, when adding, as the database has grown larger in size, the code hangs up specifically on the .AddNew command in section (c) below.

Here is the code -- can anyone help me figure out a solution that speeds it up?

Thanks,
Michael

Public Sub run()

    StoreDataAccess "A", ThisWorkbook.Path & "\rawdata.accdb", "RawData, RawData2, CalcData"

End Sub

Public Sub StoreDataAccess(SourceFilePrefix As String, TargetFile As Variant, TargetSheet As String)

' ==================================================================================
'
' All necessary variables to store data
'
    Dim cn As ADODB.Connection  'Will not work without reference to Microsoft ActiveX Data Objects
    Dim rs As ADODB.Recordset   'Will not work without reference to Microsoft ActiveX Data Objects
    Dim szConnect As String, szSQL As String, SrcIDSQL As String
    Dim lDB_RecCount As Long, SrcRecordsCount As Long, SrcRow As Long, SourceID As Long, dTempVal As Double
    
    Dim xlCalc As XlCalculation
    Dim i As Integer, j As Integer
    Dim bUpdate As Boolean
    
'   Change settings to improve performance
'
    With Application
        xlCalc = .Calculation
        .Calculation = xlCalculationManual
        .EnableEvents = False
        .ScreenUpdating = False
    End With

' ==================================================================================
'
'   Identify how many records need to be copied from external DataSheet
'
    Select Case SourceFilePrefix                                            'Set the ActiveCell
        Case "A"
            Range("A2").Activate
            SrcIDSQL = "Src1"
        Case "B"
            Range("A12").Activate
            SrcIDSQL = "Src2"
    End Select
    
    SrcRecordsCount = Range(ActiveCell, ActiveCell.End(xlDown)).Count       'Count the number of records

' ==================================================================================
'
'   Create the connection string to DataSheet, connect, count number of existing records
'
'
    szConnect = "Provider=Microsoft.ACE.OLEDB.12.0;" & _
                "Data Source=" & TargetFile & "; Mode=Share Deny None;"

    Set cn = CreateObject("ADODB.Connection")
    cn.Open szConnect
    
    Set rs = CreateObject("ADODB.Recordset")
    szSQL = "SELECT Count(RawData.ID) AS CountOfID FROM RawData"
    rs.Open szSQL, cn, adOpenForwardOnly
    If Not rs.EOF Then lDB_RecCount = rs.Fields(0).Value
    rs.Close
    
' ==================================================================================
'
'   We cycle through the Datasheet in a couple steps
'   a) First, initialize settings for each source record
'   b) Next, we check to see if the source ID already exists in the database
'   c) Finally, we either add or update, depending on the results of steps (b) 
'
    For SrcRow = 0 To SrcRecordsCount - 1
        
    ' ==========================================================================
    ' (a)
    '
    '   Initialize the recordset / reset the AddOrUpdate flag / identify the Source's unique ID
    '
        Set rs = Nothing
        Set rs = CreateObject("ADODB.Recordset")
        bUpdate = False
        SourceID = ActiveCell.Offset(SrcRow, 0).Value
        
    ' ==========================================================================
    ' (b)
    '
    '   We create a SQL string, to check if the SourceID exists in the database;
    '   if exists, then we set the AddOrUpdate flag
    '
        szSQL = "Select " & SrcIDSQL & " from " & TargetSheet & " where " & SrcIDSQL & " = " & SourceID
        rs.Open szSQL, cn, adOpenStatic
        If rs.RecordCount > 0 Then bUpdate = True
        rs.Close
        
        Set rs = Nothing
        Set rs = CreateObject("ADODB.Recordset")
        
        
    ' ==========================================================================
    ' (c)
    '
    '   Based on the results of (b), we set the Field values, and then add
    '   or update records in the database accordingly
    '
        With rs
            If bUpdate = True Then
                szSQL = "select * from " & TargetSheet & " where " & SrcIDSQL & " = " & SourceID
                .Open szSQL, cn, adOpenKeyset, adLockOptimistic
            Else
                szSQL = "Select * from " & TargetSheet
                .Open szSQL, cn, adOpenDynamic, adLockOptimistic
           ' THE NEXT LINE IS WHERE THE PROGRAM HANGS
                .AddNew
           End If
            
            Select Case SourceFilePrefix
            
            ' ===================================================================
            ' (d) First case, A imported data
            '
                Case "A"

                ' Add a bunch of values
                    .Fields("Field1").Value = ActiveCell.Offset(SrcRow, 1)
                    .Fields("Field2").Value = ActiveCell.Offset(SrcRow, 2)
                '   etc
            
            ' ===================================================================
            ' (e) Second case, B imported data
            '
                Case "B"
                    
                ' Add a bunch of values
                    .Fields("Field1").Value = ActiveCell.Offset(SrcRow, 1)
                    .Fields("Field2").Value = ActiveCell.Offset(SrcRow, 2)
                '   etc
    
            End Select
            
            ' ===================================================================
            ' (h) Finally, we need to set the Foreign Key value, for new records
            '
            ' Because our database has > 255 fields, we have to split our records across multiple
            ' tables; as a result, we need to set the Primary Key of our main table, RawData, as
            ' the Foreign Key of all other related tables in the database
            '
            
            If bUpdate = False Then
                .Fields("RawData2.ID") = .Fields("RawData.ID").Value
                .Fields("CalcData.ID") = .Fields("RawData.ID").Value
            End If
            
            .Update
            .Close
            
        End With
    Next SrcRow
    
    
' ==================================================================================
'
'   Finally, we wrap up and restore all of our settings
'
    Set rs = Nothing
    cn.Close
    Set cn = Nothing
    With Application
        .Calculation = xlCalc
        .EnableEvents = True
        .ScreenUpdating = True
    End With
    
End Sub