ADOFromExcelToAccess

[haffy311]

Hello,

I have VBA code which works perfectly to export the excel data into an access table.

One thing I would like to do is only export the rows where the columns containing the date stamp (column I) = the current date. This would help me from exporting data that.s already recorded in the access table.

Any advice would appreciated - current code is below.

Private Sub ADOFromExcelToAccess()


Dim cn As ADODB.Connection
Dim rs As ADODB.Recordset
Dim r As Long
'as long as the excel file is stored in the same location as the access file, this will find it.
dbpath = Application.ActiveWorkbook.Path & "\JLR CANADA_Concept_Log.accdb"
Set cn = New ADODB.Connection


cn.Open "Provider=Microsoft.ace.OLEDB.12.0;Data Source=" & dbpath & ";"


Set rs = New ADODB.Recordset
'opens the table in access
rs.Open "Concept_Logging", cn, adOpenKeyset, adLockOptimistic, adCmdTable


r = 1
Do While Len(Range("A" & r).Formula) > 0
With rs
.AddNew
'Access table field translation
.Fields("Material Number") = Range("A" & r).Value
.Fields("Width") = Range("B" & r).Value
.Fields("Depth") = Range("C" & r).Value
.Fields("Height") = Range("D" & r).Value
.Fields("WEIGHT") = Range("E" & r).Value
.Fields("PKG QTY") = Range("F" & r).Value
.Fields("Put away Qty") = Range("G" & r).Value
.Fields("WHN") = Range("H" & r).Value
.Fields("Date Stamp") = Range("I" & r).Value
.Fields("Time Stamp") = Range("J" & r).Value
.Fields("USER") = Range("K" & r).Value
.Fields("Option 1") = Range("L" & r).Value
.Fields("Option 2") = Range("M" & r).Value
.Fields("Option 3") = Range("N" & r).Value
.Fields("Option 4") = Range("O" & r).Value
.Fields("Option 5") = Range("P" & r).Value
.Update
End With
r = r + 1
Loop
rs.Close
Set rs = Nothing
cn.Close
Set cn = Nothing
    
End Sub

 

[bobsan42]

try like this:

Private Sub ADOFromExcelToAccess[COLOR=#ff0000]Today[/COLOR]()


    Dim cn As ADODB.Connection
    Dim rs As ADODB.Recordset
    Dim r As Long
    'as long as the excel file is stored in the same location as the access file, this will find it.
    dbpath = Application.ActiveWorkbook.Path & "\JLR CANADA_Concept_Log.accdb"
    Set cn = New ADODB.Connection
    
    cn.Open "Provider=Microsoft.ace.OLEDB.12.0;Data Source=" & dbpath & ";"
    
    Set rs = New ADODB.Recordset
    'opens the table in access
    rs.Open "Concept_Logging", cn, adOpenKeyset, adLockOptimistic, adCmdTable
    
    r = 1
    Do While Len(Range("A" & r).Formula) > 0
[COLOR=#ff0000]        If Range("I" & r).Value = Date Then[/COLOR]
            With rs
                .AddNew
                    'Access table field translation
                    .Fields("Material Number") = Range("A" & r).Value
                    .Fields("Width") = Range("B" & r).Value
                    .Fields("Depth") = Range("C" & r).Value
                    .Fields("Height") = Range("D" & r).Value
                    .Fields("WEIGHT") = Range("E" & r).Value
                    .Fields("PKG QTY") = Range("F" & r).Value
                    .Fields("Put away Qty") = Range("G" & r).Value
                    .Fields("WHN") = Range("H" & r).Value
                    .Fields("Date Stamp") = Range("I" & r).Value
                    .Fields("Time Stamp") = Range("J" & r).Value
                    .Fields("USER") = Range("K" & r).Value
                    .Fields("Option 1") = Range("L" & r).Value
                    .Fields("Option 2") = Range("M" & r).Value
                    .Fields("Option 3") = Range("N" & r).Value
                    .Fields("Option 4") = Range("O" & r).Value
                    .Fields("Option 5") = Range("P" & r).Value
                .Update
            End With
[COLOR=#ff0000]        End If[/COLOR]
        r = r + 1
    Loop
    rs.Close
    Set rs = Nothing
    cn.Close
    Set cn = Nothing
End Sub

 

[haffy311]

Thank you. This works perfectly and glad to see it didn't take a lot of extra code.

 

[bobsan42]

Glad I could help.