Updating date field in access from excel causes error

[madamson86]

Hello

I have got a linked table setup from Access to Sharepoint, on updating the Access table from excel I get the below error message. This is when it is trying to update the date field.

The field is too small to accept the amount of data you attempted to add. Try inserting or pasting less data.

The field is set to Date only on Sharepoint and I have tried to format the date in every way I can think when updating the field but still no luck, I am able to manually copy the data from the excel file to the table without any issues.

Any help would be greatly appreciated.

Kind Regards


Mike

[John_G]

Can you post the code that is causing the error? It's hard to diagnose without it!

Thanks

John

[madamson86]

Hello

Below is the full module.

Regards
Mike

Dim cnt As ADODB.Connection
Dim rst As ADODB.Recordset
Dim stSQL As String
Dim stCon As String
Dim wbBook As Workbook
Dim wsSheet As Worksheet
Dim rnData As Range
Dim vaData As Variant
Dim i As Long
Dim j As Long
 
Private Sub Import()
    Set wbBook = ActiveWorkbook
    Set wsSheet = wbBook.Worksheets(1)
    
     
    With wsSheet
        .Range("A:C,H:H,K:L,N:P,R:S").Delete Shift:=xlToLeft
        .Range("K2").FormulaR1C1 = "=(TODAY()-RC[-5])/31"
        .Range("K2").Copy Range("K2", Range("K" & Range("a" & Rows.Count).End(xlUp).Row))
        Columns("K:K").Copy
        Columns("K:K").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
        
        RowCount = .Range(.Range("A1"), .Range("A65535").End(xlUp)).Count
        
x = 2
For Counter = 1 To RowCount
    If Cells(x, 12 - 1) > 6 And Trim(Cells(x, 12 - 2)) = "Cancelled" Or Trim(Cells(x, 12 - 2)) = "Withdrawn" Or Trim(Cells(x, 12 - 2)) = "Paid" Or Trim(Cells(x, 12 - 2)) = "Declined" Then
        If Trim(Cells(x, 12 - 2)) = "Cancelled" Or Trim(Cells(x, 12 - 2)) = "Withdrawn" Then
            Cells(x, 12) = "Cancelled"
        Else
            If Len(Cells(x, 12 - 8)) = 0 Then
                Cells(x, 12) = "No Auth Code"
            Else
                If Cells(x, 12 - 2) = "Paid" Then
                    Cells(x, 12) = "Paid"
                Else
                    If Cells(x, 12 - 2) = "Declined" Then
                        Cells(x, 12) = "Declined"
                    End If
                End If
            End If
        End If
    Else
        If Cells(x, 12 - 1) > 6 Then
            Cells(x, 12) = "Expired"
        Else
            If Trim(Cells(x, 12 - 2)) = "Cooling Off" Or Trim(Cells(x, 12 - 2)) = "Not Paid" Then
                Cells(x, 12) = "Cooling Off"
            Else
                If Trim(Cells(x, 12 - 2)) = "Hold" Then
                    Cells(x, 12) = "On Hold"
                Else
                    Cells(x, 12) = Cells(x, 12 - 2)
                End If
            End If
        End If
    End If
    
x = x + 1
Next Counter
        
        Range("L1") = "Status"
        Columns("L:L").Copy
        Columns("J:J").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
        Range("L1") = "Status"
        Set rnData = .Range(.Range("A2"), .Range("J65536").End(xlUp))
    End With
     
     'Populate the variant-array with data from the range
    vaData = rnData.Value
     
     'Create the connection-string.
    stCon = "Provider=Microsoft.Jet.OLEDB.4.0;" & _
    "Data Source=" & "S:\Accounts (New)\Completion Diary\Completion Diary.mdb;"
     
     'Instantiate the ADO objects will we be using.
    Set cnt = New ADODB.Connection
    Set rst = New ADODB.Recordset
     
     'Open the connection.
    cnt.Open stCon
     
     'Loop through the array and use the values from it to
     'a) check the ScriptID-numbers
     'b) add or update records.
    For i = 1 To UBound(vaData)
        stSQL = "SELECT * FROM ScriptID 'WHERE Application_Number=" & vaData(i, 2)
        
       ' Test = rst.Fields("Version")
        With rst
            .Open stSQL, cnt, 3, 3
            
        Do
        bFound = False
        If .EOF = False Then
            If "" & vaData(i, 2) = rst.Fields("Application_Number") Then
                bFound = True
            Else
                rst.MoveNext
            End If
        End If
        Loop Until .EOF = True Or bFound = True
        
             'If the retrieved recordset is empty, i e the ScriptID does not exist
             'we add the new record.
            If bFound = False Or .EOF Then
                .AddNew
                .Fields("Application_Number") = vaData(i, 2)
                .Fields("Estate Agent") = vaData(i, 1)
                .Fields("Agreement Number") = vaData(i, 3)
                .Fields("Auth Code") = vaData(i, 4)
                .Fields("Customer") = vaData(i, 5)
                .Fields("Application Date") = vaData(i, 6)
                .Fields("Term") = vaData(i, 7)
                .Fields("Advance") = vaData(i, 8)
                .Fields("Last Update") = vaData(i, 9)
                .Fields("Current Status") = vaData(i, 10)
                .Fields("Title") = "N/A"
                .Fields("Updated") = 0
                
            Else
                Amend = False
                If .Fields("Estate Agent") <> vaData(i, 1) Then
                    .Fields("Estate Agent") = vaData(i, 1)
                    Amend = True
                End If
                If (IsNull(.Fields("Agreement Number")) = True And vaData(i, 3) <> "") Or .Fields("Agreement Number") <> "" & vaData(i, 3) Then
                    .Fields("Agreement Number") = vaData(i, 3)
                    Amend = True
                End If
                If IsNull(.Fields("Auth Code")) = True And vaData(i, 4) <> "" Or .Fields("Auth Code") <> "" & vaData(i, 4) Then
                    .Fields("Auth Code") = vaData(i, 4)
                    Amend = True
                End If
                If .Fields("Customer") <> vaData(i, 5) Then
                    .Fields("Customer") = vaData(i, 5)
                    Amend = True
                End If
                If .Fields("Application Date") <> vaData(i, 6) Then
                    .Fields("Application Date") = vaData(i, 6)
                    Amend = True
                End If
                If .Fields("Term") <> vaData(i, 7) Then
                    .Fields("Term") = vaData(i, 7)
                    Amend = True
                End If
                If .Fields("Advance") <> vaData(i, 8) Then
                    .Fields("Advance") = vaData(i, 8)
                    Amend = True
                End If
 
'############################################
'THIS IS WHERE I AM HAVING THE ISSUE
'############################################

                If .Fields("Last Update") <> vaData(i, 9) Then
                    .Fields("Last Update") = vaData(i, 9)
                    Amend = True
                End If
                If .Fields("Current Status") <> vaData(i, 10) Then
                    .Fields("Current Status") = vaData(i, 10)
                    Amend = True
                End If
                If Amend = True Then
                    .Fields("Updated") = 0
                End If
            End If
             'We keep the connection open but close the recordset for every loop.
            .Update
            .Close
        End With
         'Empty the SQL-query.
        stSQL = Empty
    Next
    
     'Close the connection.
    cnt.Close
     'Release objects from memory.
    Set rst = Nothing
    Set cnt = Nothing
    Application.CutCopyMode = False
    wbBook.Close False
End Sub