将Excel文件加载到Access DB

Question

As the title states I am having some issues loading an excel sheet to an Access DB. Long story short - started a new job that used an excel report that pulls data, reorganizes it and then loads it into a DB daily. That DB is then used to generate quarterly reports. It worked perfectly fine for the first month loading daily data into the db until I tried to generate the end of quarter report and has since stopped loading. The Macro still runs perfectly fine with no error but the daily data no longer loads into the DB.

Here is the code:

Sub LoadData()

Dim ADOConn As New ADODB.Connection
Dim ADORecSet As New ADODB.Recordset
Dim DBName As String
Dim TradeDate As Date

Set ws = ActiveWorkbook.Sheets("Load")
ws.Calculate

If Range("B2").Value = "" Then
 MsgBox "Please Enter Report Date"
Else

DBName = "\\spco1cfm1\Data\BONDESK\Hit Rate Report\Client_HitRate.accdb"

With ADOConn
    .Provider = "Microsoft.ACE.OLEDB.12.0"
    .Open DBName
End With

'Assigning Trade Date

TradeDate = ws.Range("TradeDate")
TradeDate = Format(TradeDate, "mm/dd/yyyy")
NumClients = ws.Range("NumClients")

ADORecSet.Open "tblCDClientProducts", ADOConn, adOpenKeyset, adLockOptimistic
nfields = ADORecSet.Fields.Count

For t = 1 To NumClients

ADORecSet.AddNew

' Inputs Data to Access Database

ADORecSet(0) = TradeDate & "_" & ws.Cells(t + 5, 1) & "_" & ws.Cells(t + 5, 2)
ADORecSet(1) = TradeDate
ADORecSet(2) = ws.Cells(t + 5, 1)
ADORecSet(3) = ws.Cells(t + 5, 2)
ADORecSet(4) = ws.Cells(t + 5, 3)
ADORecSet(5) = ws.Cells(t + 5, 4)
ADORecSet(6) = ws.Cells(t + 5, 6)
ADORecSet(7) = ws.Cells(t + 5, 9)
ADORecSet(8) = ws.Cells(t + 5, 12)
If ws.Cells(t + 5, 18).Value = "" Then
    ADORecSet(9) = 0
Else
    ADORecSet(9) = ws.Cells(t + 5, 18)
End If
ADORecSet(10) = ws.Cells(t + 5, 19)
ADORecSet(11) = ws.Cells(t + 5, 22)
ADORecSet(12) = ws.Cells(t + 5, 23)
ADORecSet(13) = ws.Cells(t + 5, 25)

'Updates the Access Database

ADORecSet.Update

Next t

'Ends connection with access

ADORecSet.Close
ADOConn.Close

End If

 End Sub

Unfortunately I am not too familiar with VBA so I cannot notice anything that would hinder it especially since everything still runs error free...

Please let me know what you think and thank you in advance for any help!

Answer 1

I feel like I have seen this same question a short time ago. Maybe I'm just imaging it though. Anyway, F8 through the code, line by line, and see where the actual error is, or consider these generic option.

ADO:

Sub ADOFromExcelToAccess()
' exports data from the active worksheet to a table in an Access database
' this procedure must be edited before use
Dim cn As ADODB.Connection, rs As ADODB.Recordset, r As Long
    ' connect to the Access database
    Set cn = New ADODB.Connection
    cn.Open "Provider=Microsoft.Jet.OLEDB.4.0; " & _
        "Data Source=C:\FolderName\DataBaseName.mdb;"
    ' open a recordset
    Set rs = New ADODB.Recordset
    rs.Open "TableName", cn, adOpenKeyset, adLockOptimistic, adCmdTable  
    ' all records in a table
    r = 3 ' the start row in the worksheet
    Do While Len(Range("A" & r).Formula) > 0 
    ' repeat until first empty cell in column A
        With rs
            .AddNew ' create a new record
            ' add values to each field in the record
            .Fields("FieldName1") = Range("A" & r).Value
            .Fields("FieldName2") = Range("B" & r).Value
            .Fields("FieldNameN") = Range("C" & r).Value
            ' add more fields if necessary...
            .Update ' stores the new record
        End With
        r = r + 1 ' next row
    Loop
    rs.Close
    Set rs = Nothing
    cn.Close
    Set cn = Nothing
End Sub

DAO:

Sub DAOFromExcelToAccess()
' exports data from the active worksheet to a table in an Access database
' this procedure must be edited before use
Dim db As Database, rs As Recordset, r As Long
    Set db = OpenDatabase("C:\FolderName\DataBaseName.mdb") 
    ' open the database
    Set rs = db.OpenRecordset("TableName", dbOpenTable) 
    ' get all records in a table
    r = 3 ' the start row in the worksheet
    Do While Len(Range("A" & r).Formula) > 0 
    ' repeat until first empty cell in column A
        With rs
            .AddNew ' create a new record
            ' add values to each field in the record
            .Fields("FieldName1") = Range("A" & r).Value
            .Fields("FieldName2") = Range("B" & r).Value
            .Fields("FieldNameN") = Range("C" & r).Value
            ' add more fields if necessary...
            .Update ' stores the new record
        End With
        r = r + 1 ' next row
    Loop
    rs.Close
    Set rs = Nothing
    db.Close
    Set db = Nothing
End Sub