My work uses a userform in excel as the front end module for an Access database. I want to make it possible to edit ALL fields in a purchase order based off of the unique transaction ID (primary key) in that database. So far, the code I use seems to randomly update some records and not others without giving any errors. the Access db is a .mdb file (2003). I am wondering if there is a command to move from field to field during edit, but can't seem to come up with a reason for why you would need it??
``
Sub EDIT_PO()
On Error GoTo ErrorHandler
Application.EnableCancelKey = xlDisabled
Application.DisplayAlerts = False
Application.ScreenUpdating = False
Dim nConnection As New ADODB.Connection
Dim nRecordset As New ADODB.Recordset
Dim sqlQuery As String
'Connection Strings - Dynamic Path
#If Win64 Then
nConnection.Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & "C:\Users\samue\OneDrive\Desktop\Database1.mdb"
#Else
nConnection.Open "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & "C:\Users\samue\OneDrive\Desktop\Database1.mdb"
#End If
sqlQuery = "Select * from PO_TABLE"
'Open the recordset
nRecordset.Open Source:=sqlQuery, ActiveConnection:=nConnection, CursorType:=adOpenKeyset, LockType:=adLockOptimistic
If nRecordset.Fields("Transaction ID").Value = CStr(POform.poformtransid.Value) Then
With nRecordset
.Fields("PO Number").Value = POform.poformponumber.Value
.Fields("PO Date").Value = CDate(POform.poformpodate.Value)
.Fields("Status").Value = POform.poformstatus.Value
.Fields("Material ID").Value = POform.poformmatid.Value
.Fields("Unit Cost").Value = CDbl(POform.poformunitcost.Value)
.Fields("QTY").Value = CDbl(POform.poformamount.Value)
.Fields("QTY Units").Value = POform.poformunits.Value
.Fields("Vendor ID").Value = POform.poformvendorid.Value
.Fields("Receipt Date").Value = CDate(POform.poformreceiptdate.Value)
.Fields("Supporting File").Value = POform.poformsf1.Value
.Fields("Lot Identifier").Value = POform.poformlotinfo.Value
.Update
.Close
End With
End If
nRecordset.Close
nConnection.Close
Application.DisplayAlerts = True
Application.ScreenUpdating = True
Exit Sub
ErrorHandler:
MsgBox Err.Description & " " & Err.Number, vbOKOnly + vbCritical, "Database Error"
Application.DisplayAlerts = True
Application.ScreenUpdating = True
nConnection.Close
End Sub
``
You just open table, so any record may be the first. Try filtering for the specific record you wish to edit:
sqlQuery = "Select * from PO_TABLE Where [Transaction ID] = '" & CStr(POform.poformtransid.Value) & "'"
or, if the ID is numeric:
sqlQuery = "Select * from PO_TABLE Where [Transaction ID] = " & CStr(POform.poformtransid.Value) & ""
Related
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... :)
I am creating a macro that looks through a folder, performs a SQL operation on each of the documents, and copies the results into another workbook; however, every time I debug and hit the Set rs = cn.Execute(sql) line I get an
"Automation Error" "Unspecified Error" .
The even weirder thing is that when I just run the code, I get an
"Execute of object _Connection failed" error.
I have tested the SQL code in microsoft SQL server already and each of these statements are almost verbatim with code I have previously got to work.
Option Explicit
Sub hardnessTests()
On Error GoTo ErrorHandling
Dim filename As Variant, n As Long
n = 0
Call turnOff
filename = Dir("T:\Marketing\Data Analytics\GIS Data\Water Quality Portal Data\County Summary Results\*")
While filename <> ""
Dim file As String, cn As Object, rs As Object, sql As String, hardField As ADODB.Field
file = "T:\Marketing\Data Analytics\GIS Data\Water Quality Portal Data\County Summary Results\" & filename
Set cn = CreateObject("ADODB.Connection")
With cn
.Provider = "Microsoft.ACE.OLEDB.12.0"
.connectionstring = "Data Source=" & file & ";Extended Properties=""Excel 12.0 Xml;HDR=YES;Readonly=false;IMEX=0"";"
.Open
End With
sql = "SELECT c.STATEFP, c.COUNTYFP, AVG(CAST(a.ResultMeasureValue AS NUMERIC)) AS Average_Surface_Water_Hardness, COUNT(a.ResultMeasureValue) AS Number_Of_Surface_Water_Tests, " & _
"AVG(CAST(b.ResultMeasureValue AS NUMERIC)) AS Average_Groundwater_Hardness, COUNT(b.ResultMeasureValue) AS Number_Of_Groundwater_Tests " & _
"FROM (SELECT * FROM [Sheet1$] WHERE CAST(LEFT(ActivityStartDate, 4) AS NUMERIC) >= 2010 and ActivityMediaSubdivisionName = 'Surface Water') a, " & _
"(SELECT * FROM [Sheet1$] WHERE CAST(LEFT(ActivityStartDate, 4) AS NUMERIC) >= 2010 AND ActivityMediaSubdivisionName = 'Groundwater') b, " & _
"(SELECT * FROM [Sheet1$] WHERE CAST(LEFT(ActivityStartDate, 4) AS NUMERIC) >= 2010 ) c GROUP BY c.STATEFP, c.COUNTYFP ORDER BY c.STATEFP, c.COUNTYFP"
Set rs = cn.Execute(sql)
Dim wb As Workbook, fieldCount As Long
fieldCount = 0
Set wb = Workbooks.Add
wb.SaveAs "T:\Marketing\Data Analytics\GIS Data\Water Quality Portal Data\County Summary Results\ALL_HARDNESS.xlsx"
If n = 0 Then
wb.Worksheets("Sheet1").Range("A2").CopyFromRecordset rs
Else:
wb.Worksheets("Sheet1").Range("A2").End(xlDown).CopyFromRecordset rs
End If
filename = Dir
n = n + 1
Wend
For Each hardField In rs.Fields
wb.Worksheets("Sheet1").Range("A1").Offset(0, fieldCount) = hardField.Name
fieldCount = fieldCount + 1
Next hardField
Call turnOn
Exit Sub
ErrorHandling:
MsgBox ("Source: " & Err.Source & vbNewLine & "Number: " & Err.Number & vbNewLine & "Description: " & Err.Description & vbNewLine & "Help Context: " & Err.HelpContext)
Done:
End Sub
Private Sub turnOff()
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
End Sub
Private Sub turnOn()
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = True
End Sub
Thanks for any help!
Every day i need to make a report for salesman, we have 2 dbf files from witch i automatic want to make the report in Excel. Report from 1 dbf file works perfect, but i don't know how to join 2 dbf files in VBA.
I have to following script:
Option Explicit
Sub ReadDBF()
Dim con As Object
Dim rs As Object
Dim DBFFolder As String
Dim FileName As String
Dim FileName1 As String
Dim sql As String
Dim myValues() As String
Dim i As Integer
Dim j As Integer
Application.ScreenUpdating = False
DBFFolder = ThisWorkbook.Path & "\"
FileName = "project1.dbf"
FileName1 = "project2.dbf"
On Error Resume Next
Set con = CreateObject("ADODB.connection")
If Err.Number <> 0 Then
MsgBox "Connection was not created!", vbCritical, "Connection error"
Exit Sub
End If
On Error GoTo 0
con.Open "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & DBFFolder & ";Extended Properties=dBASE IV;"
sql = "SELECT project_id, COUNT(*) AS total, salesman, MAX(date) AS max_date, projectname FROM " & FileName & FileName1 & " where DateValue(datumtijd) = Date() and FileName.project_id = FileName1.project_id " & "group by project_id, salesman"
On Error Resume Next
Set rs = CreateObject("ADODB.recordset")
If Err.Number <> 0 Then
MsgBox "Connection was not created!", vbCritical, "Connection error"
Exit Sub
End If
On Error GoTo 0
rs.CursorLocation = 3
rs.CursorType = 1
rs.Open sql, con
ReDim myValues(rs.RecordCount, 20)
i = 1
If Not (rs.EOF And rs.BOF) Then
'Go to the first record.
rs.MoveFirst
Do Until rs.EOF = True
myValues(i, 1) = rs!project_id
myValues(i, 2) = rs!salesman
myValues(i, 3) = rs!Total
myValues(i, 4) = rs!max_date
myValues(i, 5) = rs!project
rs.MoveNext
i = i + 1
Loop
Else
rs.Close
con.Close
Set rs = Nothing
Set con = Nothing
Application.ScreenUpdating = True
MsgBox "There are no records in the recordset!", vbCritical, "No Records"
Exit Sub
End If
Sheet1.Activate
For i = 1 To UBound(myValues)
For j = 1 To 4
Cells(i + 1, j) = myValues(i, j)
Next j
Next i
rs.Close
con.Close
Set rs = Nothing
Set con = Nothing
Columns("A:D").EntireColumn.AutoFit
Application.ScreenUpdating = True
MsgBox "The values were read from recordset successfully!", vbInformation, "Done"
End Sub
The query doesn't work just by adding the two tables together as the from source. What is it you are trying to actually get? Also, you should never concatenate strings to build a query. They should always be parameterized.
Now, that said, your syntax is simply incorrect. Your variables are referred to as "FileName" and "FileName1", but the underlying TABLES you are querying from are "Project1" and "Project2" respectively. You should learn about aliases to help simplify queries too, and learn proper JOIN syntax.
By listing the tables one after the other with no comma will cause it to fail. Here is a more accurate syntax and formatted for readability. Then I have edited your original query to match the context. You should also always qualify the field names from the respective table so others trying to help know where things are coming from. In the sample below, I have only GUESSED at which table has which columns by using the alias "P1." and "P2." respectively. You will probably need to change them. Also, since "Date" could be interpreted as a reserved word, I have wrapped it in [], but may need to be changed to tick characters (next to number 1) ``
select
P1.Project_ID,
COUNT(*) as Total,
P1.SalesMan,
MAX( P2.[Date] ) as Max_Date,
P1.ProjectName
from
Project1 P1
JOIN Project2 P2
on P1.Project_ID = P2.Project_ID
where
DateValue( P2.datumtijd ) = date()
group by
P1.Project_ID,
P1.SalesMan
The JOIN clause identifies the relation BETWEEN the two tables on respective columns. The WHERE clause is additional criteria you are looking for.
sql = "SELECT project_id, COUNT(*) AS total, salesman, " & _
"MAX(date) AS max_date, projectname " & _
" FROM " & FileName & " P1 " & _
" JOIN " & FileName1 & " P2 ON P1.Project_ID = P2.Project_ID" & _
" where DateValue(datumtijd) = Date() " & _
" group by project_id, salesman"
Microsoft Access 2010 database gives me the following error
"Compile error: Syntax error"
In VBA window for this form it highlights the following line of code at line 3 "strSQL = "SELECT PID from tblMSCSPersonnel WHERE SSN = '" & Me!TextSSN & "';" "
The entire code is below
Private Sub Form_Current()
Dim strSQL As String
strSQL = "SELECT PID from tblMSCSPersonnel WHERE SSN = '" & Me!TextSSN & "';"
Set rs = CurrentDb.OpenRecordset(strSQL)
If rs.RecordCount = 0 Then ' not in the personnel database
CmdAddToPersonnel.Enabled = True
Else
CmdAddToPersonnel.Enabled = False
End If
If Me![CmdSubmit].Visible = True Then
Me![CmdSubmit].Visible = False
Me![cmdCancel].Visible = False
End If
End Sub
Thanks
Maybe remove the semicolon and use Me.
strSQL = "SELECT PID from tblMSCSPersonnel WHERE SSN = '" & Me.TextSSN & "'"
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