Using Excel to Open an Access Database

gheyman

Well-known Member
Joined
Nov 14, 2005
Messages
2,332
Office Version
  1. 365
Platform
  1. Windows
I want to open my access database from my excel sheet which has the file path in a cell.

Code:
Sub GetPath07()
    Dim FName As Variant
    FName = Application.GetOpenFilename(filefilter:="Access Files,*.acc*")
    Sheet1.Range("B18").Value = FName
 End Sub

is there a way to open this database? And Can I indicate which from to open in the code or do I have to do that part in access?

Code:
Sub Export_Data()
'Export to Access CMOP Database
'
UserId
Timestamp

Dim tbl As ListObject
Dim cn As ADODB.Connection, rs As ADODB.Recordset, r As Long

'Set tbl = ThisWorkbook.Sheets("CMOUpload").ListObjects("CMOPTable")

' connect to the Access database
Set cn = New ADODB.Connection
'cn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & dbPath
cn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & Sheet1.Range("B18").Value 'Data Source=E:\Development Activities\Freelancer\Projects\In Progress\Upload data from Excel to an Access database - from excel - Greg\Database1.accdb"

' open a recordset
Set rs = New ADODB.Recordset
rs.Open "tbl_CMOP", cn, adOpenKeyset, adLockOptimistic, adCmdTable
' all records in a table
r = 1 ' the start row in the worksheet
Do While r <= Range("CMOPTable").Rows.Count
' repeat until first empty cell in column A
With rs
.AddNew 'create a new record
'add values to each field in the record

.Fields("ItemID") = ThisWorkbook.Worksheets("CMOPUpload").Range("CMOPTable[ItemID]").Cells(r)
.Fields("ItemDescription") = ThisWorkbook.Worksheets("CMOPUpload").Range("CMOPTable[ItemDescription]").Cells(r)
.Fields("Rev") = ThisWorkbook.Worksheets("CMOPUpload").Range("CMOPTable[Rev]").Cells(r)
.Fields("UM") = ThisWorkbook.Worksheets("CMOPUpload").Range("CMOPTable[UM]").Cells(r)
.Fields("CommCode") = ThisWorkbook.Worksheets("CMOPUpload").Range("CMOPTable[CommCode]").Cells(r)
.Fields("BuyerID") = ThisWorkbook.Worksheets("CMOPUpload").Range("CMOPTable[BuyerID]").Cells(r)
.Fields("Buyer") = ThisWorkbook.Worksheets("CMOPUpload").Range("CMOPTable[Buyer]").Cells(r)
.Fields("VendorID") = ThisWorkbook.Worksheets("CMOPUpload").Range("CMOPTable[VendorID]").Cells(r)
.Fields("DRSProgram") = ThisWorkbook.Worksheets("CMOPUpload").Range("CMOPTable[DRSProgram]").Cells(r)
.Fields("ReqNum") = ThisWorkbook.Worksheets("CMOPUpload").Range("CMOPTable[ReqNum]").Cells(r)
.Fields("DRSRFQID") = ThisWorkbook.Worksheets("CMOPUpload").Range("CMOPTable[DRSRFQID]").Cells(r)
.Fields("Userstamp") = ThisWorkbook.Worksheets("CMOPUpload").Range("CMOPTable[UserStamp]").Cells(r)
.Fields("DRSRFQID") = ThisWorkbook.Worksheets("CMOPUpload").Range("CMOPTable[DRSRFQID]").Cells(r)
.Fields("SolicitationDate") = ThisWorkbook.Worksheets("CMOPUpload").Range("CMOPTable[SolicitationDate]").Cells(r)
.Fields("VendorQuoteID") = ThisWorkbook.Worksheets("CMOPUpload").Range("CMOPTable[VendorQuoteID]").Cells(r)
.Fields("QuoteRev") = ThisWorkbook.Worksheets("CMOPUpload").Range("CMOPTable[QuoteRev]").Cells(r)

'******************
'User Should Enter a Date Only
'Need code here that if the code errors bacuase of one of the next two lines, error message saying data must
'_be a valid date.  And then code stops so that it doesnt debug erro
'******************

.Fields("QuoteDate") = ThisWorkbook.Worksheets("CMOPUpload").Range("CMOPTable[QuoteDate]").Cells(r)
.Fields("QuoteExpiration") = ThisWorkbook.Worksheets("CMOPUpload").Range("CMOPTable[QuoteExpiration]").Cells(r)

'******************
'User Should Enter Number Values Only
'Need code here that if the code errors bacuase of one of the next two lines, error message saying data must
'_be a whole Number.  And then code stops so that it doesnt debug erro
'******************
.Fields("LeadTime") = ThisWorkbook.Worksheets("CMOPUpload").Range("CMOPTable[LeadTime]").Cells(r)
.Fields("MOQ") = ThisWorkbook.Worksheets("CMOPUpload").Range("CMOPTable[MOQ]").Cells(r)

'******************
'User Should Enter Dollar/Number Values Only
'Need code here that if the code errors, an error message saying data must
'_be a dollar value.  And then code stops so that it doesnt debug erro
'******************

.Fields("UnitPrice") = ThisWorkbook.Worksheets("CMOPUpload").Range("CMOPTable[UnitPrice]").Cells(r)
.Fields("R1") = ThisWorkbook.Worksheets("CMOPUpload").Range("CMOPTable[R1]").Cells(r)
.Fields("R5") = ThisWorkbook.Worksheets("CMOPUpload").Range("CMOPTable[R5]").Cells(r)
.Fields("R10") = ThisWorkbook.Worksheets("CMOPUpload").Range("CMOPTable[R10]").Cells(r)
.Fields("R25") = ThisWorkbook.Worksheets("CMOPUpload").Range("CMOPTable[R25]").Cells(r)
.Fields("R50") = ThisWorkbook.Worksheets("CMOPUpload").Range("CMOPTable[R50]").Cells(r)
.Fields("R75") = ThisWorkbook.Worksheets("CMOPUpload").Range("CMOPTable[R75]").Cells(r)
.Fields("R100") = ThisWorkbook.Worksheets("CMOPUpload").Range("CMOPTable[R100]").Cells(r)
.Fields("R250") = ThisWorkbook.Worksheets("CMOPUpload").Range("CMOPTable[R250]").Cells(r)
.Fields("R500") = ThisWorkbook.Worksheets("CMOPUpload").Range("CMOPTable[R500]").Cells(r)
.Fields("R750") = ThisWorkbook.Worksheets("CMOPUpload").Range("CMOPTable[R750]").Cells(r)
.Fields("R1000") = ThisWorkbook.Worksheets("CMOPUpload").Range("CMOPTable[R1000]").Cells(r)
.Fields("R2000") = ThisWorkbook.Worksheets("CMOPUpload").Range("CMOPTable[R2000]").Cells(r)
.Fields("R3000") = ThisWorkbook.Worksheets("CMOPUpload").Range("CMOPTable[R3000]").Cells(r)
.Fields("R5000") = ThisWorkbook.Worksheets("CMOPUpload").Range("CMOPTable[R5000]").Cells(r)
.Fields("R6000") = ThisWorkbook.Worksheets("CMOPUpload").Range("CMOPTable[R6000]").Cells(r)
.Fields("R7500") = ThisWorkbook.Worksheets("CMOPUpload").Range("CMOPTable[R7500]").Cells(r)
.Fields("R10000") = ThisWorkbook.Worksheets("CMOPUpload").Range("CMOPTable[R10000]").Cells(r)
.Fields("R13000") = ThisWorkbook.Worksheets("CMOPUpload").Range("CMOPTable[R13000]").Cells(r)
.Fields("R15000") = ThisWorkbook.Worksheets("CMOPUpload").Range("CMOPTable[R15000]").Cells(r)
.Fields("R20000") = ThisWorkbook.Worksheets("CMOPUpload").Range("CMOPTable[R20000]").Cells(r)
.Fields("R23000") = ThisWorkbook.Worksheets("CMOPUpload").Range("CMOPTable[R23000]").Cells(r)
.Fields("R26000") = ThisWorkbook.Worksheets("CMOPUpload").Range("CMOPTable[R26000]").Cells(r)
.Fields("NRE") = ThisWorkbook.Worksheets("CMOPUpload").Range("CMOPTable[NRE]").Cells(r)
.Fields("SetUpCharge") = ThisWorkbook.Worksheets("CMOPUpload").Range("CMOPTable[SetUpCharge]").Cells(r)
.Fields("FAI") = ThisWorkbook.Worksheets("CMOPUpload").Range("CMOPTable[FAI]").Cells(r)
.Fields("1E") = ThisWorkbook.Worksheets("CMOPUpload").Range("CMOPTable[1E]").Cells(r)
.Fields("5E") = ThisWorkbook.Worksheets("CMOPUpload").Range("CMOPTable[5E]").Cells(r)
.Fields("10E") = ThisWorkbook.Worksheets("CMOPUpload").Range("CMOPTable[10E]").Cells(r)
.Fields("25E") = ThisWorkbook.Worksheets("CMOPUpload").Range("CMOPTable[25E]").Cells(r)
.Fields("50E") = ThisWorkbook.Worksheets("CMOPUpload").Range("CMOPTable[50E]").Cells(r)
.Fields("75E") = ThisWorkbook.Worksheets("CMOPUpload").Range("CMOPTable[75E]").Cells(r)
.Fields("100E") = ThisWorkbook.Worksheets("CMOPUpload").Range("CMOPTable[100E]").Cells(r)
.Fields("200E") = ThisWorkbook.Worksheets("CMOPUpload").Range("CMOPTable[200E]").Cells(r)
.Fields("250E") = ThisWorkbook.Worksheets("CMOPUpload").Range("CMOPTable[250E]").Cells(r)
.Fields("500E") = ThisWorkbook.Worksheets("CMOPUpload").Range("CMOPTable[500E]").Cells(r)
.Fields("750E") = ThisWorkbook.Worksheets("CMOPUpload").Range("CMOPTable[750E]").Cells(r)
.Fields("1000E") = ThisWorkbook.Worksheets("CMOPUpload").Range("CMOPTable[1000E]").Cells(r)
.Fields("2000E") = ThisWorkbook.Worksheets("CMOPUpload").Range("CMOPTable[2000E]").Cells(r)
.Fields("3000E") = ThisWorkbook.Worksheets("CMOPUpload").Range("CMOPTable[3000E]").Cells(r)
.Fields("5000E") = ThisWorkbook.Worksheets("CMOPUpload").Range("CMOPTable[5000E]").Cells(r)
.Fields("6000E") = ThisWorkbook.Worksheets("CMOPUpload").Range("CMOPTable[6000E]").Cells(r)
.Fields("7500E") = ThisWorkbook.Worksheets("CMOPUpload").Range("CMOPTable[7500E]").Cells(r)
.Fields("10000E") = ThisWorkbook.Worksheets("CMOPUpload").Range("CMOPTable[10000E]").Cells(r)
.Fields("13000E") = ThisWorkbook.Worksheets("CMOPUpload").Range("CMOPTable[13000E]").Cells(r)
.Fields("15000E") = ThisWorkbook.Worksheets("CMOPUpload").Range("CMOPTable[15000E]").Cells(r)
.Fields("20000E") = ThisWorkbook.Worksheets("CMOPUpload").Range("CMOPTable[20000E]").Cells(r)
.Fields("23000E") = ThisWorkbook.Worksheets("CMOPUpload").Range("CMOPTable[23000E]").Cells(r)
.Fields("26000E") = ThisWorkbook.Worksheets("CMOPUpload").Range("CMOPTable[26000E]").Cells(r)
.Fields("VendorEscFactor") = ThisWorkbook.Worksheets("CMOPUpload").Range("CMOPTable[VendorEscFactor]").Cells(r)

'************
'Text Values
'************

.Fields("CageCode") = ThisWorkbook.Worksheets("CMOPUpload").Range("CMOPTable[CageCode]").Cells(r)
.Fields("NAICSCode") = ThisWorkbook.Worksheets("CMOPUpload").Range("CMOPTable[NAICSCode]").Cells(r)
.Fields("BusClass") = ThisWorkbook.Worksheets("CMOPUpload").Range("CMOPTable[BusClass]").Cells(r)
.Fields("BusDesignation") = ThisWorkbook.Worksheets("CMOPUpload").Range("CMOPTable[BusDesignation]").Cells(r)
.Fields("LineComments") = ThisWorkbook.Worksheets("CMOPUpload").Range("CMOPTable[LineComments]").Cells(r)


.Update 'stores the new record
End With

r = r + 1 'next row
Loop
rs.Close
Set rs = Nothing
cn.Close
Set cn = Nothing
Set tbl = Nothing


'communicate with the user
 MsgBox " The data has been successfully sent to the database"

'Update the sheet
 Application.ScreenUpdating = True


 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

Thanks for the Help
 

Excel Facts

Using Function Arguments with nested formulas
If writing INDEX in Func. Arguments, type MATCH(. Use the mouse to click inside MATCH in the formula bar. Dialog switches to MATCH.

Forum statistics

Threads
1,213,504
Messages
6,114,016
Members
448,543
Latest member
MartinLarkin

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top