I have an access connection file (.accdb) that allows me to use EXCEL (Office 365) to query a SharePoint Library. It all works great EXCEPT for new files added to that SharePoint Library. I can query for and return all data for these new files/entries but cannot get the filename for these new entries for some reason. Any help would be most appreciated.
Const SQLIMSSHAREPOINTCONNECTION = "Provider=Microsoft.ACE.OLEDB.12.0; Data Source = C:\MORGAN\MACROS\IMS_SHAREPOINT_db.accdb"
Sub routine:
Dim i As Long
Dim cn As Object
Dim rs As Object
Dim StrSql As String
Dim thePieces1() As String
Dim thePieces2() As String
Dim theFullFilename As String
Dim theShortFilename As String
StrSql = "SELECT [Name], [ID], [PartNumber(s)], [DateCompleted], [DocumentType], " & _
"[WorkOrder(s)], [PurchaseOrder(s)], [SalesOrder(s)], [CustomerName(s)], [WorkCenter]" & _
" FROM [Inspection Reports]"
Set cn = CreateObject("ADODB.Connection")
cn.Open SQLIMSSHAREPOINTCONNECTION
Set rs = CreateObject("ADODB.RECORDSET")
rs.ActiveConnection = cn
rs.Open StrSql
If Not (rs.BOF And rs.EOF) Then
i = 1
On Error Resume Next
Do While Not rs.EOF
i = i + 1
theFullFilename = ""
theShortFilename = ""
ReDim thePieces1(10)
thePieces1 = Split(rs.Fields(0), "#")
theFullFilename = thePieces1(1)
thePieces1() = Split(theFullFilename, "/")
theShortFilename = thePieces1(UBound(thePieces1))
Range("A" & i).Value = rs.Fields(1) ' ID
Range("B" & i).Value = theShortFilename ' Filename
Range("C" & i).Value = rs.Fields(2) ' PartNumber(s)
Range("D" & i).Value = rs.Fields(3) ' DateCompleted
Range("E" & i).Value = rs.Fields(4) ' DocumentType
Range("F" & i).Value = rs.Fields(5) ' WorkOrder(s)
Range("G" & i).Value = rs.Fields(6) ' PurchaseOrder(s)
Range("H" & i).Value = rs.Fields(7) ' CustomerName
Range("I" & i).Value = rs.Fields(8) ' WorkCenter
rs.MoveNext
Loop
It's not clear to me how your sharepoint access Excel connection works, but your recordset (rs) probably needs a refresh or requery after you updated the sharepoint data.
Related
i want to excute below code in specific sheet, without activating that sheet.
since do while references are in sheet1,code should work in sheet1.
when I working on sheet2 code dosenot work.
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
'Dim sht As Worksheet
Set cn = New ADODB.Connection
cn.Open "PROVIDER=Microsoft.ACE.OLEDB.12.0;DATA SOURCE=D:\Trading\Option Analysis.accdb;PERSIST SECURITY INFO=FALSE;Jet OLEDB:System database=C:\Users\kishor\AppData\Roaming\Microsoft\Access\System1.mdw;"
' open a recordset
Set rs = New ADODB.Recordset
rs.Open "CE", cn, adOpenKeyset, adLockOptimistic, adCmdTable
' all records in a table
r = 2 ' 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("Date") = Range("A" & r).Value
.Fields("Time") = Range("B" & r).Value
.Fields("LTP") = Range("C" & r).Value
.Fields("Chg") = Range("D" & r).Value
.Fields("OI") = Range("E" & r).Value
.Fields("Volume") = Range("F" & r).Value
.Fields("Strike_Price") = Range("G" & r).Value
.Fields("Option_Type") = Range("H" & r).Value
.Fields("OI_Change") = Range("I" & r).Value
.Fields("IV") = Range("J" & r).Value
.Fields("Expiry") = Range("K" & 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
Set rs = New ADODB.Recordset
rs.Open "PE", cn, adOpenKeyset, adLockOptimistic, adCmdTable
' all records in a table
r = 2 ' 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("Date") = Range("O" & r).Value
.Fields("Time") = Range("P" & r).Value
.Fields("LTP") = Range("Q" & r).Value
.Fields("Chg") = Range("R" & r).Value
.Fields("OI") = Range("S" & r).Value
.Fields("Volume") = Range("T" & r).Value
.Fields("Strike_Price") = Range("U" & r).Value
.Fields("Option_Type") = Range("V" & r).Value
.Fields("OI_Change") = Range("W" & r).Value
.Fields("IV") = Range("X" & r).Value
.Fields("Expiry") = Range("Y" & 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
Set rs = New ADODB.Recordset
rs.Open "Spot", cn, adOpenKeyset, adLockOptimistic, adCmdTable
rs.AddNew ' create a new record
' add values to each field in the record
rs.Fields("Date") = Range("AB" & 2).Value
rs.Fields("Time") = Range("AC" & 2).Value
rs.Fields("Spot") = Range("AD" & 2).Value
rs.Fields("OI_SUM") = Range("AD" & 3).Value
rs.Update
rs.Close
Set rs = Nothing
cn.Close
Set cn = Nothing
Call datatimer
End Sub
i want to excute below code in specific sheet, without activating that sheet.
since do while references are in sheet1,code should work in sheet1. when I working on sheet2 code dosenot work.
request for support from experts
I have webi report exported in .xlsx format with 3 tables from 3 tabs which I need to export to a Access Database.
The person who's going to run the webi report then copy the data from excel to access is located overseas and cannot open and work on the Access Database itself. (Has the access but latency issue makes things difficult)
The exported webi report cannot come with a macro, so I've created an Excel workbook with a single macro which will read the data from exported webi report then add it to the existing tables in Access Database.
Below code works if there are no 'matching primary keys' already in the database tables. But I need to improve it so it will overwrite any data with matching primary keys & create new entries for new primary keys.
What complicates things is that 2 of the 3 tables have 2 fields as the Primary Key, and the other table has 3 fields as Primary Key.
Could anyone help me with this issue please?
(If I can do this straight from WebI that would be fantastic but I couldn't find a working solution.)
Table1:
mDate: Primary Key
Country: Primary Key
Table2:
mDate: Primary Key
Country: Primary Key
Table3:
mDate: Primary Key
mTime: Primary Key
Country: Primary Key
VBA Code:
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
Dim wb As Workbook
Set wb = Workbooks("Exported_webi_Report")
Set wb1 = wb.Worksheets("tbl1")
Set wb2 = wb.Worksheets("tbl2")
Set wb3 = wb.Worksheets("tbl3")
' connect to the Access database
Set cn = New ADODB.Connection
cn.Open "Provider=Microsoft.ACE.OLEDB.12.0; " & _
"Data Source=\\networkdrive\database.accdb;"
' open a recordset
Set rs = New ADODB.Recordset
rs.Open "tbl1", cn, adOpenKeyset, adLockOptimistic, adCmdTable
' all records in a table
r = 8 ' the start row in the worksheet
Do While Len(wb1.Range("B" & 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("mDate") = wb1.Range("B" & r).Value
.Fields("Country") = wb1.Range("C" & r).Value
.Fields("1") = wb1.Range("D" & r).Value
.Fields("2") = wb1.Range("E" & r).Value
.Fields("3") = wb1.Range("F" & r).Value
.Fields("4") = wb1.Range("G" & r).Value
.Fields("5") = wb1.Range("H" & r).Value
.Fields("6") = wb1.Range("I" & r).Value
.Fields("7") = wb1.Range("J" & r).Value
.Fields("8") = wb1.Range("K" & r).Value
.Fields("9") = wb1.Range("L" & 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
' open a recordset
Set rs = New ADODB.Recordset
rs.Open "tbl2", cn, adOpenKeyset, adLockOptimistic, adCmdTable
' all records in a table
r = 8 ' the start row in the worksheet
Do While Len(wb2.Range("B" & 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("mDate") = wb2.Range("B" & r).Value
.Fields("Country") = wb2.Range("C" & r).Value
.Fields("1") = wb2.Range("D" & 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
' open a recordset
Set rs = New ADODB.Recordset
rs.Open "tbl3", cn, adOpenKeyset, adLockOptimistic, adCmdTable
' all records in a table
r = 8 ' the start row in the worksheet
Do While Len(wb3.Range("B" & 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("mDate") = wb3.Range("B" & r).Value
.Fields("mTime") = wb3.Range("C" & r).Value
.Fields("Country") = wb3.Range("D" & r).Value
.Fields("1") = wb3.Range("E" & r).Value
.Fields("2") = wb3.Range("F" & r).Value
.Fields("3") = wb3.Range("G" & 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
EDIT::
' open a recordset
Set rs = New ADODB.Recordset
rs.Open "tbl1", cn, adOpenKeyset, adLockOptimistic, adCmdTable
' all records in a table
r = 8 ' the start row in the worksheet
Do While Len(wb1.Range("B" & 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("mDate") = wb1.Range("B" & r).Value
.Fields("Country") = wb1.Range("C" & r).Value
.Fields("1") = wb1.Range("D" & r).Value
.Fields("2") = wb1.Range("E" & r).Value
.Fields("3") = wb1.Range("F" & r).Value
.Fields("4") = wb1.Range("G" & r).Value
.Fields("5") = wb1.Range("H" & r).Value
.Fields("6") = wb1.Range("I" & r).Value
.Fields("7") = wb1.Range("J" & r).Value
.Fields("8") = wb1.Range("K" & r).Value
.Fields("9") = wb1.Range("L" & 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
Following Tim's advice, I've changed above part of the code as below.
Dim sql As String, pk1 As Variant, pk2 As Variant, pk3 As Variant, pk As Variant
' open a recordset
Set rs = New ADODB.Recordset
' all records in a table
r = 8 ' the start row in the worksheet
Do While Len(wb1.Range("B" & r).Formula) > 0
' repeat until first empty cell in column A
With rs
pk1 = wb1.Range("B" & r).Value
pk2 = wb1.Range("C" & r).Value
strSQL = "SELECT * " & _
"FROM tbl1 " & _
"WHERE [tbl1].[mDate] = # " & pk1 & " # " & _
"AND [tbl1].[Country] = ' " & pk2 & " ';"
.Open Source:=strSQL, _
ActiveConnection:=cn, _
CursorType:=adOpenDynamic, _
LockType:=adLockOptimistic, _
Options:=adCmdText
'if EOF add new record otherwise overwrite old record
If .EOF = True Then
.AddNew 'Create a new record
End If
' add values to each field in the record
.Fields("mDate") = pk1
.Fields("Country") = pk2
.Fields("1") = wb1.Range("D" & r).Value
.Fields("2") = wb1.Range("E" & r).Value
.Fields("3") = wb1.Range("F" & r).Value
.Fields("4") = wb1.Range("G" & r).Value
.Fields("5") = wb1.Range("H" & r).Value
.Fields("6") = wb1.Range("I" & r).Value
.Fields("7") = wb1.Range("J" & r).Value
.Fields("8") = wb1.Range("K" & r).Value
.Fields("9") = wb1.Range("L" & 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
When run, it tries to add new data for existing dates and comes back with an error message saying that I'm trying to make a duplicate Primary Key.
EDIT #2
Continuing with Tim's instructions, I've closed the recordset inside each loop,(And no spaces between dates and #) as below.
Dim sql As String, pk1 As Variant, pk2 As Variant, pk3 As Variant, pk As Variant
' open a recordset
Set rs = New ADODB.Recordset
' all records in a table
r = 8 ' the start row in the worksheet
Do While Len(wb1.Range("B" & r).Formula) > 0
' repeat until first empty cell in column A
With rs
pk1 = wb1.Range("B" & r).Value
pk2 = wb1.Range("C" & r).Value
strSQL = "SELECT * " & _
"FROM tbl1 " & _
"WHERE [tbl1].[mDate] = #" & pk1 & "# " & _
"AND [tbl1].[Country] = ' " & pk2 & " ';"
.Open Source:=strSQL, _
ActiveConnection:=cn, _
CursorType:=adOpenDynamic, _
LockType:=adLockOptimistic, _
Options:=adCmdText
'if EOF add new record otherwise overwrite old record
If .EOF = True Then
.AddNew 'Create a new record
End If
' add values to each field in the record
.Fields("mDate") = pk1
.Fields("Country") = pk2
.Fields("1") = wb1.Range("D" & r).Value
.Fields("2") = wb1.Range("E" & r).Value
.Fields("3") = wb1.Range("F" & r).Value
.Fields("4") = wb1.Range("G" & r).Value
.Fields("5") = wb1.Range("H" & r).Value
.Fields("6") = wb1.Range("I" & r).Value
.Fields("7") = wb1.Range("J" & r).Value
.Fields("8") = wb1.Range("K" & r).Value
.Fields("9") = wb1.Range("L" & r).Value
' add more fields if necessary...
.Update ' stores the new record
End With
r = r + 1 ' next row
rs.Close
Set rs = Nothing
Loop
Now, it worked well for last couple of days in August(30th and 31st).
But as soon as it encounters Sep 1st, it tries to create a new record and comes back with duplicate pk error.
What could I be doing wrong? I though it might be the date format so I tried to manually match all date formats which resulted the same error.
Any help would be appreciated.
Thank you.
To remove the duplicates of Table1 from Access database, try the code below.
(not tested)
dim sql as string, pk1 as variant, pk2 as variant, pk3 as variant, pk as variant
dim i as long
with wb1
pk1 = application.transpose(.range(.range("B8"), .cells(.rows.count,2).end(xlup)).value)
pk2 = application.transpose(.range(.range("B8"), .cells(.rows.count,2).end(xlup)).offset(,1).value)
end with
for i = lbound(pk1) to ubound(pk1)
if pk1(i) > 0 then
if isarray(pk) then
redim preserve pk(ubound(pk)+1) as variant
else
redim pk(0) as variant
end if
pk(ubound(pk)) = "'" & format(pk1(i),"yyyymmdd") & "_" & pk2(i) & "'"
else
exit for
end if
next i
sql = "DELETE FROM tbl1 WHERE Format(mDate, ""yyyymmdd"") & ""_"" & country IN (" & join(pk, ", ") & ")"
cn.execute sql
I have a table in access that I would like to update from excel vba. The new data comes from a saved excel file and each row has an unique ID as their primary key. I would like to make it so that when the new data comes in, any existing entry who's primary key matches that of a new entry will be replaced and any new data that is not replacing an old entry will create a new entry. I believe this is called a left or right join but I am not sure. Currently, my code only adds a new recordset and I can't seem to make it do a join because I am not too familiar with Access vba nor making excel and access talk to each other.
This is my code, which is run from excel:
Function AppendShipment(DatabaseLocation, ExcelFileLocation, dbTableName)
Dim wkb As Excel.Workbook
Dim wks As Excel.Worksheet
Set wkb = Workbooks.Open(ExcelFileLocation)
Set wks = wkb.Worksheets("Sheet1")
Dim strConnection As String
Dim db As Object
Dim rs As Object
Dim r As Integer
Application.ScreenUpdating = False
strConnection = "Provider=Microsoft.ACE.OLEDB.12.0; Data Source=" &
DatabaseLocation
Set db = CreateObject("ADODB.Connection")
db.Open strConnection
' open a recordset
Set rs = CreateObject("ADODB.Recordset")
rs.Open dbTableName, db, adOpenKeyset, adLockOptimistic
r = 2 ' the start row in the worksheet
Do While Not Cells(r, 1) = ""
' repeat until first empty cell in column A
With rs
.AddNew ' create a new record
' add values to each field in the record
.Fields("Customer") = Range("A" & r).Value
.Fields("Customer Name") = wks.Range("B" & r).Value
.Fields("Order Date") = wks.Range("C" & r).Value
.Fields("Contract") = wks.Range("D" & r).Value
.Fields("Sales Order") = wks.Range("E" & r).Value
.Fields("Line#") = wks.Range("F" & r).Value
.Fields("Customer Part") = wks.Range("G" & r).Value
.Fields("AFS Part") = wks.Range("H" & r).Value
.Fields("Decription 1") = wks.Range("I" & r).Value
.Fields("Site") = wks.Range("J" & r).Value
.Fields("Product Code") = wks.Range("K" & r).Value
.Fields("Qty Ship") = wks.Range("L" & r).Value
.Fields("Unit Price") = wks.Range("M" & r).Value
.Fields("Customer PO Number") = wks.Range("N" & r).Value
.Fields("Invoice Date") = wks.Range("O" & r).Value
.Fields("Ship Date") = wks.Range("P" & r).Value
.Fields("Ship To") = wks.Range("Q" & r).Value
.Fields("Shipped-Dollars") = wks.Range("R" & r).Value
.Fields("Month1") = wks.Range("S" & r).Value
.Fields("Year1") = wks.Range("Y" & r).Value
.Fields("Product Line") = wks.Range("U" & r).Value
.Fields("Customer Group") = wks.Range("V" & r).Value
.Fields("Customer&Product") = wks.Range("W" & r).Value
.Fields("Customer Group 2") = wks.Range("X" & r).Value
.Fields("Product Subgroup (Type 1)") = wks.Range("Y" & r).Value
.Fields("Product Subgroup (Type 2)") = wks.Range("Z" & r).Value
' add more fields if necessary...
.Update ' stores the new record
End With
r = r + 1 ' next row
Loop
rs.Close
db.Close
ActiveWorkbook.Close SaveChanges:=False
Application.ScreenUpdating = True
End Function
Any helps is appreciated, thank you!
To use a JOIN for an "UPSERT" in MS Access is only possible if the query has access to the source data. In your case, the source data is in Excel and you have to process each single row separately. I suggest to search the unique key in the database to decide whether to add a new record or edit the existing one:
' repeat until first empty cell in column A
With rs
.FindFirst "[Sales Order]=" & wks.Range("E" & r).Value & _
" AND [Line#] = " & wks.Range("F" & r).Value
If .NoMatch Then .AddNew Else .Edit ' create a new or edit existing record
' add values to each field in the record
.Fields....
Since I can't see your data types, I assumed that both [Sales Order] and [Line#] are numbers. If not, you will have to wrap single quotes around the cell values calling the .FindFirst method.
I figured it out!
First, i used .Filter to see if anything matches the current records. If .RecordCount = 0, then nothing matches, so then it does .AddNew. If something does match, it turns out .Edit doesn't work for ADO, instead .MoveFirst needs to be used. Since only 1 recordset will ever match because I am filtering by the primary key and there can be no duplicates, this will edit that recordset no problem.
Function AppendShipment(DatabaseLocation, ExcelFileLocation, dbTableName)
Dim wkb As Excel.Workbook
Dim wks As Excel.Worksheet
Set wkb = Workbooks.Open(ExcelFileLocation)
Set wks = wkb.Worksheets("Sheet1")
Dim strConnection As String
Dim db As Object
Dim rs As Object
Dim r As Integer
Application.ScreenUpdating = False
strConnection = "Provider=Microsoft.ACE.OLEDB.12.0; Data Source=" & DatabaseLocation
Set db = CreateObject("ADODB.Connection")
db.Open strConnection
' open a recordset
Set rs = CreateObject("ADODB.Recordset")
rs.Open dbTableName, db, adOpenKeyset, adLockOptimistic
r = 2 ' the start row in the worksheet
Do While Not Cells(r, 1) = ""
' repeat until first empty cell in column A
With rs
Debug.Print "[UniqueDB_ID]=" & "'" & Trim(wks.Range("E" & r).Value) &
wks.Range("F" & r).Value & "'"
.Filter = "[UniqueDB_ID]=" & "'" & Trim(wks.Range("E" & r).Value) &
wks.Range("F" & r).Value & "'"
If .RecordCount = 0 Then .AddNew Else .MoveFirst ' create a new record or
edit existing record
' add values to each field in the record
.Fields("UniqueDB_ID") = Trim(wks.Range("E" & r).Value) & wks.Range("F" &
r).Value
.Fields("Customer") = wks.Range("A" & r).Value
.Fields("Customer Name") = wks.Range("B" & r).Value
.Fields("Order Date") = wks.Range("C" & r).Value
.Fields("Contract") = wks.Range("D" & r).Value
.Fields("Sales Order") = Trim(wks.Range("E" & r).Value)
.Fields("Line#") = wks.Range("F" & r).Value
.Fields("Customer Part") = wks.Range("G" & r).Value
.Fields("AFS Part") = wks.Range("H" & r).Value
.Fields("Decription 1") = wks.Range("I" & r).Value
.Fields("Site") = wks.Range("J" & r).Value
.Fields("Product Code") = wks.Range("K" & r).Value
.Fields("Qty Ship") = wks.Range("L" & r).Value
.Fields("Unit Price") = wks.Range("M" & r).Value
.Fields("Customer PO Number") = wks.Range("N" & r).Value
.Fields("Invoice Date") = wks.Range("O" & r).Value
.Fields("Ship Date") = wks.Range("P" & r).Value
.Fields("Ship To") = wks.Range("Q" & r).Value
.Fields("Shipped-Dollars") = wks.Range("R" & r).Value
.Fields("Month1") = wks.Range("S" & r).Value
.Fields("Year1") = wks.Range("Y" & r).Value
.Fields("Product Line") = wks.Range("U" & r).Value
.Fields("Customer Group") = wks.Range("V" & r).Value
.Fields("Customer&Product") = wks.Range("W" & r).Value
.Fields("Customer Group 2") = wks.Range("X" & r).Value
.Fields("Product Subgroup (Type 1)") = wks.Range("Y" & r).Value
.Fields("Product Subgroup (Type 2)") = wks.Range("Z" & r).Value
' add more fields if necessary...
.Update ' stores the new record
End With
r = r + 1 ' next row
Loop
rs.Close
db.Close
ActiveWorkbook.Close SaveChanges:=False
Application.ScreenUpdating = True
End Function
Thank you for your help!
I am working on an Excel application which allows users to enter hours work through userforms and info is stored in a Access DB. I am new to excel and access connections. I am able to connect to the database but record is not saved/created due to a run-time error at the .Update command.
Run-Time Error '-2147467259 (80004005)': Operation must use an updatable query.
I have searched and searched and can't find a solution to this problem. I hope someone is able to help. (code below)
Sub Export_Data_Access_TI1()
Dim dbPath As String
Dim x As Long, i As Long
Dim nextrow As Long
Dim user As String
Dim NewSht As Worksheet
Dim strQuery As String
Dim recDate As String
Dim Week_Of As String
user = Sheet1.Range("A1").Text
On Error GoTo ErrHandler:
'Variables for file path and last row of data
dbPath = "H:\PROJECTS\CAI_DOT-Time Tracker\CAI_EMP_SignIn_Database.accdb"
nextrow = Cells(Rows.Count, 1).End(xlUp).Row
'Initialise the collection class variable
Set cnn = New ADODB.Connection
'Check for data
If Sheets(user).Range("A2").Value = "" Then
MsgBox " There is no data to send to MS Access"
Exit Sub
End If
cnn.Mode = adModeReadWrite
'cnn.Mode = adModeShareDenyNone
cnn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & dbPath
Set rst = New ADODB.Recordset 'assign memory to the recordset
rst.CursorLocation = adUseClient
rst.Open Source:="DATA", ActiveConnection:=cnn, _
CursorType:=adOpenKeyset, LockType:=adLockPessimistic, _
Options:=adCmdTable
'rst.Supports (adAddNew)
x = 2 'the start row in the worksheet
Do While Len(Sheets(user).Range("A" & x).Formula) > 0
With rst
.AddNew 'create a new record
.Fields("Date") = ActiveWorkbook.Sheets(user).Range("A" & x).Value
.Fields("Week_Of") = Sheets(user).Range("B" & x).Value
.Fields("Month") = Sheets(user).Range("C" & x).Value
.Fields("Name") = Sheets(user).Range("D" & x).Value
.Fields("Time_In") = Sheets(user).Range("E" & x).Value
.Fields("Time_Out") = Sheets(user).Range("F" & x).Value
.Fields("Time_In2") = Sheets(user).Range("G" & x).Value
.Fields("Time_Out2") = Sheets(user).Range("H" & x).Value
.Fields("Group") = Sheets(user).Range("I" & x).Value
.Fields("UniqueID") = Sheets(user).Range("J" & x).Value
.Fields("Comments") = Sheets(user).Range("K" & x).Value
.Update 'stores the new record
End With
x = x + 1 'next row
Loop
rst.Close
cnn.Close
Set rst = Nothing
Set cnn = Nothing
'communicate with the user
MsgBox " The data has been successfully sent to the access database"
'Update the sheet
Application.ScreenUpdating = True
'Clear the data
'Sheets(user).Range("A1:K1000").ClearContents
On Error GoTo 0
Exit Sub
ErrHandler:
'clear memory
Set rst = Nothing
Set cnn = Nothing
MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure Export_Data"
End Sub
As I understand, DATA is a query in the remote accdb. If so, it should be updateable. See, for example this: Why is my query not updateable? for criterias. If this is a table, check if you have read-write rights on accdb and the file has no read-only attribute.
I have queried a excel using ADODB and have a set of data which should be copied to the second worksheet, but when ever i try to insert data it always sits on the 2nd row ignoring the 1st one. I think this is because the 1st row is always treated as header. Are there any ways to insert data into the excel by creating 1st row as header and subsequently with values(with respect to the code i have written below).
Exceldb = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=C:\VAS_AUTOMATION_v1.1\Book1.xlsx;Extended Properties=""Excel 12.0;HDR=Yes;"";"
Dim sDBConnectionString, i, iCol
Set con = CreateObject("ADODB.Connection")
sDBConnectionString = Exceldb
con.ConnectionString = sDBConnectionString
con.Open
If Err.Number <> 0 Then
For i = 1 to 4
Err.Clear
wait 5
con.Open
If Err.Number = 0 Then
msgbox "opened"
End If
Next
else
msgbox "opened"
End If
strROW = "UNIXOPERATIONS_16"
strROWID = "'" & strROW & "'"
strQuery = "INSERT INTO [Sheet3$A1:A1] (" & strROWID1 & ") Values(" & strROWID & ")"
Set strRecordSet = CreateObject("ADODB.Recordset")
Dim objCmd 'As New ADODB.Command
Set objCmd = CreateObject("ADODB.Command")
Set objCmd.ActiveConnection = con
objCmd.CommandType = 1
objCmd.CommandText = strQuery
Set strRecordSet = objCmd.Execute
con.Close