How to Transfer VBA UserForm Data To Access Database? - vba

I have created a user form in excel to save my records in a sheets like sheet1.
But after few days working with this UserForm, it is now goes slower, because of heavy data saving in sheet1.
Now I want to save all records to a database and want to keep clean my sheet1.
So I can work on my UserForm easily or without any delay. Also wants updates my record by calling it via serial numbers.
but I don't want to keep any record in my sheet1.
my little code is below: -
Sub cmdAdd_Click()
On Error GoTo ErrOccured
BlnVal = 0
If BlnVal = 0 Then Exit Sub
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
Dim txtId, txtName, GenderValue, txtLocation, txtCNum, txtEAddr, txtRemarks
Dim iCnt As Integer
iCnt = fn_LastRow(Sheets("Data")) + 1
If frmData.obMale = True Then
GenderValue = "Male"
Else
GenderValue = "Female"
End If
With Sheets("Data")
.Cells(iCnt, 1) = iCnt - 1
.Cells(iCnt, 2) = frmData.txtName
.Cells(iCnt, 3) = GenderValue
.Cells(iCnt, 4) = frmData.txtLocation.Value
.Cells(iCnt, 5) = frmData.txtEAddr
.Cells(iCnt, 6) = frmData.txtCNum
.Cells(iCnt, 7) = frmData.txtRemarks
.Columns("A:G").Columns.AutoFit
.Range("A1:G1").Font.Bold = True
.Range("A1:G1").LineStyle = xlDash
End If
End With
Dim IdVal As Integer
IdVal = fn_LastRow(Sheets("Data"))
frmData.txtId = IdVal
ErrOccured:
'TurnOn screen updating
Application.ScreenUpdating = True
Application.EnableEvents = True
End Sub
I will always be grateful to you.

Then, please try the next way. I will try creating of the necessary DB, table and fields using Excel VBA, too:
Copy the next piece of code which will create an empty DB, on the path you want:
Sub CreateEmptyDB()
Dim strPath As String, objAccess As Object
strPath = "C:\Your path\testDB"
Set objAccess = CreateObject("Access.Application")
Call objAccess.NewCurrentDatabase(strPath)
objAccess.Quit
End Sub
Programatically create the necessary table with its fields (`Start Date' added only to see how this type of data is handled...):
Sub createTableFields()
'It needs a reference to `Microsoft ActiveX Data Objects 2.x Library` (x = 2 to 9)
Dim Catalog As Object, cn As ADODB.Connection
Dim dbPath As String, scn As String, strTable As String
dbPath = "C:\Teste VBA Excel\testAccess\testDB.accdb"
strTable = "MySpecial_Table"
scn = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & dbPath & ";"
Set Catalog = CreateObject("ADOX.Catalog")
Set cn = New ADODB.Connection
With cn
.Open scn
.Execute "CREATE TABLE " & strTable & " ([Name] text(255) WITH " & _
"Compression, " & "[Gender] text(255) WITH Compression, " & _
"[Location] text(255) WITH Compression, " & _
"[Address] text(255) WITH Compression, " & _
"[Number] number, " & _
"[Remarks] text(255) WITH Compression, " & _
"[Start Date] datetime)"
End With
cn.Close
End Sub
Add records to the newly created DB/Table:
Sub FillDataInDB()
'It needs a reference to `Microsoft ActiveX Data Objects 2.x Library` (x = 2 to 9)
Dim AccessDB As String, strTable As String, sql As String
Dim con As ADODB.Connection, rs As ADODB.Recordset, lastNo As Long
AccessDB = "C:\Teste VBA Excel\testAccess\testDB.accdb"
strTable = "MySpecial_Table"
Set con = CreateObject("ADODB.connection")
con.Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & AccessDB
sql = "SELECT * FROM " & strTable
Set rs = CreateObject("ADODB.Recordset")
rs.CursorType = 1 'adOpenKeyset on early binding
rs.LockType = 3 'adLockOptimistic on early binding
rs.Open sql, con
If rs.RecordCount = 0 Then
lastNo = 0 'when no records in the table
Else
rs.MoveLast: lastNo = rs("Number") 'the last recorded value
End If
rs.AddNew
rs("Name") = "Test name" 'frmData.txtName
rs("Gender") = "Test gender" 'GenderValue
rs("Location") = "Test Location" 'frmData.txtLocation.Value
rs("Address") = "Test Address" 'frmData.txtEAddr
rs("Number") = IIf(lastNo = 0, 100, lastNo + 1) 'auto incrementing against the last value
'but starting from 100
'you can use frmData.txtCNum
rs("Remarks") = "Remarkable table..." 'frmData.txtRemarks
rs("Start Date") = Date
rs.Update
rs.Close: con.Close
Set rs = Nothing: Set con = Nothing
End Sub
Run the first two pieces of code in consecutive order (only once) and then start playing with the third one...
You can read the newly created DB Table (returning in an Excel sheet) in this way:
Sub ADO_Connection_ReadTable()
Dim conn As New Connection, rec As New Recordset, sh As Worksheet
Dim AccessDB As String, connString, query As String, strTable As String
AccessDB = "C:\Teste VBA Excel\testAccess\testDB.accdb"
strTable = "MySpecial_Table"
Set sh = ActiveSheet 'use here the sheet you want
connString = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & AccessDB
conn.Open connString
query = "SELECT * from " & strTable & ";"
rec.Open query, conn
'return in the sheet
sh.cells.ClearContents
'getting data from the recordset if any and returning some in columns A:B:
If (rec.RecordCount <> 0) Then
Do While Not rec.EOF
With sh.Range("A" & sh.cells(Rows.count, 1).End(xlUp).row).Offset(1, 0)
.Value2 = rec.fields(0).Value
.Offset(0, 1).Value2 = rec.fields(3)
End With
rec.MoveNext
Loop
End If
rec.Close: conn.Close
End Sub
You can use a query to return specific data according to a specific table field. You can find plenty of examples on the internet.
I tried also showing how to handle an automate recording for the 'Number' field. Of course, if you are able to keep track of it in a different way, you can record it as you need/wont.
Please, test the above code(s) and send some feedback. You can use the DB path as a Private constant at the module level and much other ways to optimize the code. It is just a minimum workable solution only showing the way... :)

Related

Using an existing external data connection to create a recordset

I have a macro that I use to get data from an Access database, pass it into a recordset and then drop it into a worksheet in a crosstab format. Currently all my data starts in a SQL Server, gets pulled into Access, and then my macro takes it from there.
I’m trying to cut Access out of the process. What I need is the code to point at an external data source rather than to an Access mdb, which results in me getting the same recordset for the rest of the macro to process. My whole code is below; I’ve marked the part I’m looking to change.
' Gets the prior incurred claims estimates data from the Access database
' "RestatedIncurredClaims.mdb" in the same folder as the model, and sets up
' the tables on the Prior_Claims sheet to contain the data.
Public Sub GetPriorClaimsData()
If [MODEL_NAME] = "" Then
Dim modelName As String
modelName = Replace(ThisWorkbook.Name, "ReserveModel_", "")
modelName = Left(modelName, InStr(modelName, ".") - 1)
[MODEL_NAME] = modelName
End If
' WANT TO CHANGE THIS PART
Dim dbPath As String
dbPath = ThisWorkbook.Path & "\RestatedIncurredClaims.mdb"
Application.Calculation = xlCalculationManual
On Error GoTo priorClaimsErr
Application.StatusBar = "Opening prior claims database..."
' Open the database
' Options:=False means non-exclusive, see:
' http://msdn.microsoft.com/en-us/library/office/ff835343.aspx
Dim db As Database
Set db = Workspaces(0).OpenDatabase(Name:=dbPath, _
Options:=False, ReadOnly:=True)
Application.StatusBar = "Getting prior claims data..."
' Execute query to get prior incurred claim estimates for this model only
Dim rs As Recordset
Set rs = db.OpenRecordset( _
"SELECT * FROM [Restated incurred claims] WHERE [model_name] = """ _
& [MODEL_NAME] & """")
' WANT TO LEAVE EVERYTHING ELSE THE SAME
Dim i As Long, numCellsFound As Long
Dim iLOB As Long, iTOS As Long, iReported As Long, iIncurred As Long
numCellsFound = 0
' Create the array that will hold the prior claims data during processing
Dim priorClaimsData() As Variant
ReDim priorClaimsData( _
0 To [PRIOR_CLAIMS_TABLES].Rows.Count - 1, _
0 To [PRIOR_CLAIMS_TABLES].Columns.Count - 1)
If rs.RecordCount > 0 Then
Application.StatusBar = "Clearing prior claims data..."
[PRIOR_CLAIMS_TABLES].ClearContents
Dim lookupLOB As New Dictionary
For i = 1 To [LST_LINES].Cells.Count
lookupLOB([LST_LINES].Cells(i).Value) = i
Next
Dim lookupTOS As New Dictionary
For i = 1 To [LST_TYPES_SHORT].Cells.Count
lookupTOS([LST_TYPES_SHORT].Cells(i).Value) = i
Next
Dim lookupDate As New Dictionary
For i = 1 To [PRIOR_CLAIMS_DATES].Cells.Count
lookupDate([PRIOR_CLAIMS_DATES].Cells(i).Value) = i
Next
rs.MoveFirst
Do Until rs.EOF
If rs.AbsolutePosition Mod 1000 = 0 Then
Application.StatusBar = "Processing prior claims data, row " _
& Format(rs.AbsolutePosition, "#,0") & "..."
End If
iLOB = lookupLOB(CStr(rs!model_lob))
iTOS = lookupTOS(CStr(rs!fnc_ben_typ_cd))
iReported = lookupDate(CStr(rs!acct_perd_yr_mo))
iIncurred = lookupDate(CStr(rs!clm_incr_yr_mo))
If iLOB <> 0 And iTOS <> 0 _
And iReported <> 0 And iIncurred <> 0 Then
iLOB = iLOB - 1
iTOS = iTOS - 1
iReported = iReported - 1
iIncurred = iIncurred - 1
priorClaimsData( _
iLOB * ROWS_PER_LOB + iIncurred, _
iTOS * COLS_PER_TOS + iReported) = rs!rst_incur_clm
numCellsFound = numCellsFound + 1
End If
rs.MoveNext
Loop
[PRIOR_CLAIMS_TABLES].Value = priorClaimsData
End If
If numCellsFound = 0 Then
MsgBox Prompt:="No prior estimates data found for this model (" _
& [MODEL_NAME] & ").", _
Title:="Warning", _
Buttons:=vbExclamation + vbOKOnly
End If
GoTo closeDb
priorClaimsErr:
MsgBox Prompt:="Failed to update the prior claim estimates data:" _
& vbCrLf & vbCrLf & Err.Description, _
Title:="Warning", _
Buttons:=vbExclamation + vbOKOnly
closeDb:
Application.StatusBar = "Closing prior claims database..."
If Not rs Is Nothing Then
rs.Close
Set rs = Nothing
End If
If Not db Is Nothing Then
db.Close
Set db = Nothing
End If
Application.StatusBar = "Recalculating..."
Application.Calculation = xlCalculationAutomatic
Application.StatusBar = False
End Sub
I initially thought that if I established the data connection and had it saved in an .odc file, that referencing that file in vba would be simple. But all I’ve been able to find is code for establishing new data connections directly in vba with a connection string. Is this what I have to do? If so is there a way to do it so that the code will work regardless of the user running it?
I'm using Excel 2010
Thanks
This is an ADO code sample you can use to connect to SQL Server:
You must add a reference to 'Microsoft ActiveX Data Objects 6.1' first
SQLSERVER_CONN_STRING = "Provider=SQLOLEDB.1;Data Source=<server name or IP address>;User ID=<User_id>;Password=<pwd>;Initial Catalog=<initial cat>;"
Dim oConn As ADODB.Connection
Dim rs as ADODB.Recorset
Dim sSQL as String
Set oConn = New ADODB.Connection
oConn.CommandTimeout = 60
oConn.ConnectionTimeout = 30
oConn.Open SQLSERVER_CONN_STRING
Set rs = New ADODB.Recordset
'note that SQL Server query syntax is different!
sSql = "SELECT * FROM [Restated incurred claims] WHERE [model_name] = '" & [MODEL_NAME] & "'")
rs.Open sSQL, oConn, adOpenStatic, adLockOptimistic, adCmdText
If Not rs Is Nothing Then
If rs.State = 1 Then
If rs.RecordCount > 0 Then
<your code here>
end if
End If
End If
If Not rs Is Nothing Then
If rs.State = 1 Then rs.Close
End if
If Not oConn Is Nothing Then
If oConn.State = 1 Then oConn.Close
End if

Add list item to sharepoint list using vba

Im trying to create an excel tool that will add list item to sharepoint custom list. I had theinitial code but i am getying an error "couldnt find installable ISAM". My excel is 2016 and running in windows 10. How can i fix this issue?
Public Const sDEMAND_ROLE_GUID As String = "{6AA0B273-2548-49ED-9592-78243D4353AC}"
Public Const sSHAREPOINT_SITE As String = "https://eu001-sp.domain.com/sites/"
Sub TestPullFromSharepoint()
Dim cn As ADODB.Connection
Dim rs As ADODB.Recordset
Dim sConn As String
Dim sSQL As String
Dim ID As String
sConn = "Provider=Microsoft.ACE.OLEDB.12.0;DATABASE=" & sSHAREPOINT_SITE & ";" & _
"LIST=" & sDEMAND_ROLE_GUID & ";Extended Properties='Excel 8.0;HDR=YES;IMEX=1;';"
Set cn = New ADODB.Connection
Set rs = New ADODB.Recordset
With cn
.ConnectionString = sConn
.Open
End With
sSQL = "SELECT tbl.[name] FROM [Library Name] as tbl where tbl.[id] = 14"
rs.Open sSQL, cn, adOpenStatic, adLockOptimistic
End Sub
I know it isn't super pretty, but I have a solution... Make sure that you replace YOURSHAREPOINTSITE with the url of your site.
The beauty of my solution, is that the code allows for:
Creation of new SP list
Addition of list items with all original column of the list
Addition of list items with any number of columns of the list (as
long as all required columns are represented)
No link required for the addition of new data (does create a link
when you use #1 but not a syncing link)
Limitations:
Column validation will cause a failed run if you pass data that
shouldn't go in that column (text to number column)
Absent required columns cause a failed run
Untested with lookup, people/group, or other record related column
types... but it would cause invalid data, potentially a failed run
unless you input the ID of the lookup value... which you probably
don't have.
It does require correct typing of column names and list name in
input boxes...
Public Sub PushSPList()
Dim lname As String, guid As String
Dim arr, arrr
Dim NewList As ListObject
Dim L As ListObjects
' Get the collection of lists for the active sheet
Set L = ThisWorkbook.ActiveSheet.ListObjects
' Add a new list
If MsgBox("Have you selected the new data?", vbYesNo) = vbNo Then
Exit Sub
Else
If MsgBox("New?", vbYesNo) = vbYes Then
lname = InputBox("What is the name of your new list?")
Set NewList = L.Add(xlSrcRange, Selection, , xlYes, True)
NewList.Name = lname
' Publish it to a SharePoint site
NewList.Publish Array("https://YOURSHAREPOINTSITE", lname), False
Else
arr = getSPitems
lname = arr(2)
guid = arr(1)
Set NewList = L(1)
Set arrr = Selection
Call addSPListItem(arrr, lname, guid)
End If
End If
End Sub
Sub addSPListItem(rar As Variant, lnme, guid)
Dim arr, lguid As String, spurl As String, lname As String, uitem As Object
lguid = guid
lname = lnme
spurl = "https://YOURSHAREPOINTSITE"
Dim cnt As ADODB.Connection
Dim rst As ADODB.Recordset 'tb
Dim mySQL As String
Set cnt = New ADODB.Connection
Set rst = New ADODB.Recordset
mySQL = "SELECT * FROM [" & lname & "];"
With cnt
.ConnectionString = _
"Provider=Microsoft.ACE.OLEDB.12.0;WSS;IMEX=0;RetrieveIds=Yes;" & _
"DATABASE=" & spurl & _
";LIST=" & lguid & ";"
.Open
End With
rst.Open mySQL, cnt, adOpenDynamic, adLockOptimistic
Dim fld As Object
Dim arrr()
i = -1
For Each fld In rst.Fields
i = i + 1
ReDim Preserve arrr(0 To i)
arrr(i) = rst.Fields(i).Name
Next
Dim clmns
clmns = Split(InputBox("Select columns, separated by commas, no spaces after commas... " & Join(arrr, ", ")), ",")
Dim Colmns As Object
Set Colmns = CreateObject("Scripting.Dictionary")
For i = 0 To UBound(clmns)
Colmns(i) = clmns(i)
Next
jj = 1
Do While rar(jj, 1) ""
rst.AddNew
For kk = 0 To UBound(clmns)
rst.Fields(Colmns(kk)) = rar(jj, kk + 1)
Next
jj = jj + 1
Loop
rst.Update
If CBool(rst.State And adStateOpen) = True Then rst.Close
Set rst = Nothing
If CBool(cnt.State And adStateOpen) = True Then cnt.Close
Set cnt = Nothing
MsgBox "Done"
End Sub

VBA code to loop and update MS access database column from Excel

Background:
I have an excel spreadsheet that retrieves data from an MS Access database. That code works fine. It retrieves records that have the "comments" field as blank. Users update the comments field in Excel and click a button.
The Ask: Once the button is clicked, the VBA code must loop through all retrieved records in my excel sheet and those records that are marked "completed" in excel must update the same comment in the "comments field" in my database.
I have looked at this article and Gord Thompson posted some code that could work for my situation; except that i dont know how to tailor that code to work for me :(
Link--
VBA code to update / create new record from Excel to Access
**Snapshot of the structure of my database and excel at this ** link
excel:
database:
Will this code work
Sub Update()
Dim cn As ADODB.Connection, rs As ADODB.Recordset
Dim xComments As String
Dim xType As String
Dim xIBES_Ticker As String
Dim xEditor As String
Dim xPRD_Year As String
Dim xPRD_Month As String
Dim xEvent_Date As String
Dim xReporting As String
Dim xNotes As String
' connect to the Access database
Set cn = New ADODB.Connection
cn.Open "Provider=Microsoft.ACE.OLEDB.12.0; " & _
"Data Source=C:\Database1.mdb;"
' open a recordset
Set rs = New ADODB.Recordset
rs.Open "tablename", cn, adOpenKeyset, adLockOptimistic, adCmdTable
Range("A2").Activate ' row 1 contains column headings
Do While Not IsEmpty(ActiveCell)
'filter all columns and update all records back instead of looking for those marked with "complete"
'guessing this will be easier to do
rs.Filter = "Type='" & xType & "' AND IBES_Ticker='" & xIBES_Ticker & "' AND Editor='" & xEditor & "' AND PRD_Year='" & xPRD_Year & "' AND PRD_Month='" & xPRD_Month & "' AND Event_Date='" & xEvent_Date & "' AND Reporting='" & xReporting & "' AND Notes='" & xNotes & "' AND Comments='" & xComments & "' "
If rs.EOF Then
Debug.Print "No existing records found..."
rs.Filter = ""
Else
Debug.Print "Existing records found..."
End If
rs("Type").Value = xType
rs("IBES_Ticker").Value = xIBES_Ticker
rs("Editor").Value = xEditor
rs("PRD_Year").Value = xPRD_Year
rs("PRD_Month").Value = xPRD_Month
rs("Event_Date").Value = xEvent_Date
rs("Reporting").Value = xReporting
rs("Notes").Value = xNotes
rs("Comments").Value = xComments
rs.Update
Debug.Print "...record update complete."
ActiveCell.Offset(1, 0).Activate ' next cell down
Loop
rs.Close
Set rs = Nothing
cn.Close
Set cn = Nothing
End Sub
I am not sure what bit of the adaptation you are struggling with. The following might help:
Sub update()
Dim r as Range
Set r = [J2] ' shorthand for Range("J2")
While r.offset(0, -3).Value > 0
If r.Value = "Complete" Then
' take this record and put it in the DB
End If
Set r = r.offset(1,0) ' go to the next row
Wend
End Sub
Is that the bit you had difficulty with? If it is something else, please leave a comment.
UPDATE I don't have Access, so it is a little bit hard to give more guidance. However, I found the following code snippet for updating a record in Access (see http://msdn.microsoft.com/en-us/library/office/ff845201(v=office.15).aspx )
UPDATE tblCustomers
SET Email = 'None'
WHERE [Last Name] = 'Smith'
I think we can use that with the above and do something like this:
Sub update()
Dim cn As ADODB.Connection, rs As ADODB.Recordset
' connect to the Access database
Set cn = New ADODB.Connection
cn.Open "Provider=Microsoft.ACE.OLEDB.12.0; " & _
"Data Source=C:\Database1.mdb;"
' open a recordset
Set rs = New ADODB.Recordset
rs.Open "tablename", cn, adOpenKeyset, adLockOptimistic, adCmdTable
Dim r as Range
Set r = [J2] ' shorthand for Range("J2")
While r.offset(0, -3).Value > 0
If r.Value = "Complete" Then
ticker = r.offset(0, -7)
notes = r.offset(0, -1)
' create the query string - something like this?
qString = "UPDATE table name SET Notes='" & notes & "' WHERE IBES_Ticker='" & ticker
' now put it in the database:
cn.Execute qString, dbFailOnError
End If
set r = r.offset(1,0) ' go to the next row
Wend
' now close your connections properly…
rs.Close
Set rs = Nothing
cn.Close
Set cn = Nothing
End Sub

Using Excel VBA to export data to MS Access table

I am currently using following code to export data from worksheet to MS Access database, the code is looping through each row and insert data to MS Access Table.
Public Sub TransData()
Application.ScreenUpdating = False
Application.EnableAnimations = False
Application.EnableEvents = False
Application.DisplayAlerts = False
ActiveWorkbook.Worksheets("Folio_Data_original").Activate
Call MakeConnection("fdMasterTemp")
For i = 1 To rcount - 1
rs.AddNew
rs.Fields("fdName") = Cells(i + 1, 1).Value
rs.Fields("fdDate") = Cells(i + 1, 2).Value
rs.Update
Next i
Call CloseConnection
Application.ScreenUpdating = True
Application.EnableAnimations = True
Application.EnableEvents = True
Application.DisplayAlerts = True
End Sub
Public Function MakeConnection(TableName As String) As Boolean
'*********Routine to establish connection with database
Dim DBFullName As String
Dim cs As String
DBFullName = Application.ActiveWorkbook.Path & "\FDData.mdb"
cs = "Provider=Microsoft.Jet.OLEDB.4.0; Data Source=" & DBFullName & ";"
Set cn = CreateObject("ADODB.Connection")
If Not (cn.State = adStateOpen) Then
cn.Open cs
End If
Set rs = CreateObject("ADODB.Recordset")
If Not (rs.State = adStateOpen) Then
rs.Open TableName, cn, adOpenKeyset, adLockOptimistic
End If
End Function
Public Function CloseConnection() As Boolean
'*********Routine to close connection with database
On Error Resume Next
If Not rs Is Nothing Then
rs.Close
End If
If Not cn Is Nothing Then
cn.Close
End If
CloseConnection = True
Exit Function
End Function
Above code works fine for few hundred lines of records, but apparently it will be more data to export, Like 25000 records, is it possible to export without looping through all records and just one SQL INSERT statement to bulk insert all data to Ms.Access Table in one go?
Any help will be much appreciated.
EDIT: ISSUE RESOLVED
Just for information if anybody seeks for this, I've done a lots of search and found the following code to be work fine for me, and it is real fast due to SQL INSERT, (27648 records in just 3 seconds!!!!):
Public Sub DoTrans()
Set cn = CreateObject("ADODB.Connection")
dbPath = Application.ActiveWorkbook.Path & "\FDData.mdb"
dbWb = Application.ActiveWorkbook.FullName
dbWs = Application.ActiveSheet.Name
scn = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & dbPath
dsh = "[" & Application.ActiveSheet.Name & "$]"
cn.Open scn
ssql = "INSERT INTO fdFolio ([fdName], [fdOne], [fdTwo]) "
ssql = ssql & "SELECT * FROM [Excel 8.0;HDR=YES;DATABASE=" & dbWb & "]." & dsh
cn.Execute ssql
End Sub
Still working to add specific fields name instead of using "Select *", tried various ways to add field names but can't make it work for now.
is it possible to export without looping through all records
For a range in Excel with a large number of rows you may see some performance improvement if you create an Access.Application object in Excel and then use it to import the Excel data into Access. The code below is in a VBA module in the same Excel document that contains the following test data
Option Explicit
Sub AccImport()
Dim acc As New Access.Application
acc.OpenCurrentDatabase "C:\Users\Public\Database1.accdb"
acc.DoCmd.TransferSpreadsheet _
TransferType:=acImport, _
SpreadSheetType:=acSpreadsheetTypeExcel12Xml, _
TableName:="tblExcelImport", _
Filename:=Application.ActiveWorkbook.FullName, _
HasFieldNames:=True, _
Range:="Folio_Data_original$A1:B10"
acc.CloseCurrentDatabase
acc.Quit
Set acc = Nothing
End Sub
#Ahmed
Below is code that specifies fields from a named range for insertion into MS Access. The nice thing about this code is that you can name your fields in Excel whatever the hell you want (If you use * then the fields have to match exactly between Excel and Access) as you can see I have named an Excel column "Haha" even though the Access column is called "dte".
Sub test()
dbWb = Application.ActiveWorkbook.FullName
dsh = "[" & Application.ActiveSheet.Name & "$]" & "Data2" 'Data2 is a named range
sdbpath = "C:\Users\myname\Desktop\Database2.mdb"
sCommand = "INSERT INTO [main] ([dte], [test1], [values], [values2]) SELECT [haha],[test1],[values],[values2] FROM [Excel 8.0;HDR=YES;DATABASE=" & dbWb & "]." & dsh
Dim dbCon As New ADODB.Connection
Dim dbCommand As New ADODB.Command
dbCon.Open "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & sdbpath & "; Jet OLEDB:Database Password=;"
dbCommand.ActiveConnection = dbCon
dbCommand.CommandText = sCommand
dbCommand.Execute
dbCon.Close
End Sub

Looking up Access database in Excel

I want to do something very simple: I have an Access database with one table mapping thousands of product IDs to product information fields. In an Excel worksheet, the user types in perhaps 100 product IDs in the first column. I need for the remaining columns to pull in information from the Access database for the corresponding IDs. Specifically:
if I use MS-Query, it seems to insist on the output being a table. I simply want the output to be inside a single cell. Preferably, a formula that involves a SQL-type query.
I don't want any of the values to be updated automatically, but rather want all the columns updated only on user demand (the user could either choose refresh through a menu, or a VBA-based refresh button on the sheet is fine as well).
I'm thinking this would be a straightforward use case, but it seems surprisingly hard to find a solution. Thank you in advance!
Working from Excel, you can use ADO to connect to a database. For Access and Excel 2007/2010, you might:
''Reference: Microsoft ActiveX Data Objects x.x Library
Dim cn As New ADODB.Connection
Dim rs As New ADODB.Recordset
''Not the best way to refer to a workbook, but convenient for
''testing. it is probably best to refer to the workbook by name.
strFile = ActiveWorkbook.FullName
''Connection string for 2007/2010
strCon = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & strFile _
& ";Extended Properties=""Excel 12.0 xml;HDR=Yes;"";"
cn.Open strCon
''In-line connection string for MS Access
scn = "[;DATABASE=Z:\Docs\Test.accdb]"
''SQL query string
sSQL = "SELECT a.Stuff, b.ID, b.AText FROM [Sheet5$] a " _
& "INNER JOIN " & scn & ".table1 b " _
& "ON a.Stuff = b.AText"
rs.Open sSQL, cn
''Write returned recordset to a worksheet
ActiveWorkbook.Sheets("Sheet7").Cells(1, 1).CopyFromRecordset rs
Another possibility returns a single field from MS Access. This example uses late binding, so you do not need a library reference.
Dim cn As Object
Dim rs As Object
Dim strFile As String
Dim strCon As String
Dim strSQL As String
Dim s As String
Dim i As Integer, j As Integer
strFile = "z:\docs\test.accdb"
strCon = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & strFile
''Late binding, so no reference is needed
Set cn = CreateObject("ADODB.Connection")
Set rs = CreateObject("ADODB.Recordset")
cn.Open strCon
''Select a field based on a numeric reference
strSQL = "SELECT AText " _
& "FROM Table1 a " _
& "WHERE ID = " & Sheets("Sheet7").[A1]
rs.Open strSQL, cn, 3, 3
Sheets("Sheet7").[B1] = rs!AText
OK, this may seem a bit lengthy - Create an Excel-table - in the first row (from column two) you have the Fieldnames Exactly as you have them in the access-table, in the first column you have the desired key-values (e.g. CustomerIDs).
When you run the macro it fills in what it finds...
Sub RefreshData()
Const fldNameCol = 2 'the column with the first fieldname in it'
Dim db, rst As Object
Set db = DBEngine.workspaces(0).OpenDatabase("C:\path\to\db\name.accdb")
Set rst = db.openrecordset("myDBTable", dbOpenDynaset)
Dim rng As Range
Dim showfields() As Integer
Dim i, aRow, aCol As Integer
ReDim showfields(100)
Set rng = Me.Cells
aRow = 1 'if you have the fieldnames in the first row'
aCol = fldNameCol
'***** remove both '' to speed things up'
'On Error GoTo ExitRefreshData'
'Application.ScreenUpdating = False'
'***** Get Fieldnames from Excel Sheet'
Do
For i = 0 To rst.fields.Count - 1
If rst.fields(i).Name = rng(aRow, aCol).Value Then
showfields(aCol) = i + 1
Exit For
End If
Next
aCol = aCol + 1
Loop Until IsEmpty(rng(aRow, aCol).Value)
ReDim Preserve showfields(aCol - 1)
'**** Get Data From Databasetable'
aRow = 2 'startin in the second row'
aCol = 1 'key values (ID) are in the first column of the excel sheet'
Do
rst.FindFirst "ID =" & CStr(rng(aRow, aCol).Value) 'Replace ID with the name of the key field'
If Not rst.NoMatch Then
For i = fldNameCol To UBound(showfields)
If showfields(i) > 0 Then
rng(aRow, i).Value = rst.fields(showfields(i) - 1).Value
End If
Next
End If
aRow = aRow + 1
Loop Until IsEmpty(rng(aRow, aCol).Value)
ExitRefreshData:
Application.ScreenUpdating = True
On Error GoTo 0
End Sub
And if you dont want your fieldnames in the excel sheet replace the paragraph "Get Fieldnames From Excelsheet" with this:
fieldnames = Split("field1name", "", "", "field3name")
For j = 0 To UBound(fieldnames) - 1
For i = 0 To rst.fields.Count - 1
If rst.fields(i).Name = fieldnames(j) Then
showfields(j + fldNameCol) = i + 1
Exit For
End If
Next
Next
ReDim Preserve showfields(UBound(fieldnames) - 1 + fldNameCol)
and add this at the top
dim j as integer
dim fieldnames