When I run the following code, I receive syntax error with INSERT INTO statement.
Prior to executing the DoCMD step, the locals window shows the value of valuestring to be a string with a value of "1/4/2016"
I assume the error has to do with a string being entered into a date field, but not sure how to fix it.
Formdate is formatted as a date and data1 is not declared, though it shows up properly in the locals window as a date, #1/4/2016#
Public Sub Import2(FileName As Variant)
Dim wb As Object, ws As Object
Dim xl As Object
Set xl = CreateObject("excel.Application")
Dim qs As String
Dim ValueString As String
'opens workbook, populates data1, etc.
Set wb = xl.Workbooks.Open(FileName)
Set ws = wb.worksheets("For Export")
data1 = ws.cells(2, 1)
Data2 = ws.cells(2, 2)
Data3 = ws.cells(2, 3)
ValueString = "(" & data1 & ")"
qs = "INSERT INTO MAF (FormDate) VALUES & valuestring"
DoCmd.RunSQL qs
'CurrentDb.Execute qs
Modify like this:
Data1 = ws.cells(2, 1)
ValueString = Format(Data1, "yyyy\/mm\/dd")
qs = "INSERT INTO MAF (FormDate) VALUES (#" & valuestring & "#)"
Related
I have adapted some code I found to extract a mySQL table and write it to a worksheet. However, it is slow for some of the larger tables(30,000+). I am trying to find a better way to import the values and avoid looping. I was hoping to be able to assign it directly to a range, but have been unsuccessful. From my research, it seems Excel is limited when it comes to mySQL. Any suggestions?
Dim password As String
Dim sqlstr As String
Dim dbTable As String
'OMIT Dim Cn statement
Dim server_Name As String
Dim user_ID As String
Dim database_Name As String
Dim lRow As Integer, lCol As Integer
'Start timer
Dim Count As Long
Dim BenchMark As Double
BenchMark = Timer
Application.ScreenUpdating = False
Application.EnableEvents = False
'OMIT Dim rs statement
Set rs = CreateObject("ADODB.Recordset") 'EBGen-Daily
server_Name = Sheet10.Range("b1").Value
database_Name = Sheet10.Range("b2").Value ' Name of database
user_ID = Sheet10.Range("b3").Value 'id user or username
password = Sheet10.Range("b4").Value 'Password
dbTable = Sheet10.Range("tbl_name").Value
sqlstr = "SELECT * FROM " & dbTable
Set cn = New ADODB.Connection
'On Error Goto ErrorHandler
cn.Open "DRIVER={MySQL ODBC 8.0 Unicode Driver};" & _
"SERVER=" & server_Name & ";" & _
"DATABASE=" & database_Name & ";" & _
"USER=" & user_ID & ";" & _
"PASSWORD=" & password & ";" & _
"Option=16427"
rs.Open sqlstr, cn, adOpenStatic
'MsgBox cn.Execute("SELECT COUNT(*) As row_count FROM elite_advocacy;")!row_count + 1
Dim myArray()
myArray = rs.GetRows()
kolumner = UBound(myArray, 1)
rader = UBound(myArray, 2)
'Delete existing table
On Error Resume Next
Sheet2.ListObjects("tbl_data").Delete
On Error GoTo 0
'Write array to sheet <<< Slow for large datasets
For k = 0 To kolumner ' Using For loop data are displayed
Sheet2.Range("rng_s_data").Offset(0, k).Value = rs.Fields(k).Name
For r = 0 To rader
Sheet2.Range("rng_s_data").Offset(r + 1, k).Value = myArray(k, r)
Next
Next
'Write array to range <<< Failed
'Attempt 2
'Dim r1 As Range, rBase As Range
'Dim L As Long, U As Long
'Set rBase = Sheet2.Range("rng_s_data")
'L = LBound(myArray)
'U = UBound(myArray)
'r1 = rBase.Resize(1, rader - kolumner + 1)
'r1 = myArray
'Find lRow and lCol
lRow = Cells(Rows.Count, Range("rng_s_data").Column).End(xlUp).Row
lCol = Cells(Range("rng_s_data").Row, Columns.Count).End(xlToLeft).Column
'Create a table from Data
'Sheet2.ListObjects.Add(xlSrcRange, Sheet2.Range("A$5:$Z$100"), , xlYes).Name = "tbl_data"
Sheet2.ListObjects.Add(xlSrcRange, Sheet2.Range(Sheet2.Cells(Sheet2.Range("rng_s_data").Row, Sheet2.Range("rng_s_data").Column), _
Sheet2.Cells(lRow, lCol)), , xlYes).Name = "tbl_data"
Sheet2.ListObjects("tbl_data").TableStyle = "TableStyleLight1"
'Autofit Sheet
Cells.EntireColumn.AutoFit
Application.ScreenUpdating = True
Application.EnableEvents = True
'End Timer
MsgBox Timer - BenchMark
Errorhandler:
rs.Close
Set rs = Nothing
cn.Close
Set cn = Nothing
End Sub
I don't have mySQl for testing, but something like this would be a generic approach to querying any database from Excel using ADO.
Performance is optimum if you avoid any looping which involves cell-by-cell access, and do as much as you can with arrays, before transferring the final array to the worksheet in a single operation.
It's worth putting in extra effort to create re-usable pieces of code as standalone Subs or Functions - that allows your main logic to stay focused on the task at hand.
Sub Tester()
Dim cn As ADODB.Connection, rs As ADODB.Recordset
Dim sql As String, dbTable As String, data, rngTbl As Range
Dim BenchMark As Double
BenchMark = Timer
Set cn = GetConnection()
Set rs = New ADODB.Recordset
dbTable = Sheet10.Range("tbl_name").Value
sql = "SELECT * FROM " & dbTable
rs.Open sql, cn, adOpenStatic
data = RecordSetToArray(rs) 'Includes field names
'data = RecordSetToArray(rs,False) 'False = no field names
'Delete existing table
On Error Resume Next
sheet2.ListObjects("tbl_data").Delete
On Error GoTo 0
'put the data on the worksheet
Set rngTbl = ArrayToSheetRange(data, sheet2.Range("rng_s_data"))
With sheet2.ListObjects.Add(xlSrcRange, rngTbl, , xlYes)
.Name = "tbl_data"
.TableStyle = "TableStyleLight1"
.Range.EntireColumn.AutoFit
End With
Debug.Print "Done in " & Timer - BenchMark
End Sub
'return an opened connection object
Function GetConnection() As ADODB.Connection
Dim serverNm As String, userId As String, dbNm As String, pw As String
Dim cn As ADODB.Connection
Set cn = New ADODB.Connection
serverNm = Sheet10.Range("b1").Value
dbNm = Sheet10.Range("b2").Value ' Name of database
userId = Sheet10.Range("b3").Value 'id user or username
pw = Sheet10.Range("b4").Value 'Password
cn.Open "DRIVER={MySQL ODBC 8.0 Unicode Driver};" & _
"SERVER=" & serverNm & ";" & _
"DATABASE=" & dbNm & ";" & _
"USER=" & userId & ";" & _
"PASSWORD=" & pw & ";" & _
"Option=16427"
Set GetConnection = cn
End Function
'Create a 2-D array from a recordset
Function RecordSetToArray(rs As ADODB.Recordset, _
Optional IncludeFieldNames As Boolean = True)
Dim tmp, nC As Long, nR As Long, data, r As Long, c As Long, rowNum As Long
tmp = rs.GetRows() 'cols x rows
nC = UBound(tmp, 1) + 1 'zero-based --> 1-based
nR = UBound(tmp, 2) + 1
ReDim data(1 To nR + IIf(IncludeFieldNames, 1, 0), 1 To nC) 'allow for headers?
If IncludeFieldNames Then
For c = 1 To nC
data(1, c) = rs.Fields(c - 1).Name
Next c
rowNum = 1
End If
For r = 1 To nR
rowNum = rowNum + 1
For c = 1 To nC
data(rowNum, c) = tmp(c - 1, r - 1)
Next c
Next r
RecordSetToArray = data
End Function
'Fill an array to a worksheet starting at `rng`, and return the filled range
Function ArrayToSheetRange(data, rng As Range) As Range
Dim rv As Range
Set rv = rng.Cells(1).Resize(UBound(data, 1), UBound(data, 2))
rv.Value = data
Set ArrayToSheetRange = rv
End Function
I'm trying to use the seek method within a VBA code nested loop. The goal is to use a query to search a table for ID values that match what was identified in the first loop. I'm returning 'Method or data member not found' The error is occurring on the line 'Set StrSQL2.Index = "ID"'. Since "ID" is the only column in that table created by the query I tried commenting it out, but it only shifts the error down to the next line 'StrSQL2.Seek "=", !external_nmad_id
Public Sub EditFinalOutput2()
'set variables
Dim i As Long
Dim qs As DAO.Recordset
Dim ss As DAO.Recordset
Dim StrSQL2 As DAO.QueryDef
Dim IRSfileFormatKey As String
Dim external_nmad_id As String
Dim nmad_address_1 As String
Dim nmad_address_2 As String
Dim nmad_address_3 As String
Dim mytestwrite As String
'open reference set
Set db = CurrentDb
Set qs = db.OpenRecordset("SunstarAccountsInWebir_SarahTest")
'Set ss = db.OpenRecordset("1042s_FinalOutput_7")
'Set StrSQL1 = db.OpenRecordset("SELECT RIGHT(IRSfileFormatKey, 10) As ID
FROM 1042s_FinalOutput_7;")
With qs.Fields
intCount = qs.RecordCount - 1
For i = 0 To intCount
If (IsNull(!nmad_address_1) Or (!nmad_address_1 = !nmad_city) Or (!nmad_address_1 = !Webir_Country) And IsNull(!nmad_address_2) Or (!nmad_address_2 = !nmad_city) Or (!nmad_address_2 = !Webir_Country) And IsNull(!nmad_address_3) Or (!nmad_address_3 = !nmad_city) Or (!nmad_address_3 = !Webir_Country)) Then
DoCmd.RunSQL "INSERT INTO Addresses_ToBeReviewed SELECT SunstarAccountsInWebir_SarahTest.* FROM SunstarAccountsInWebir_SarahTest WHERE (((SunstarAccountsInWebir_SarahTest.external_nmad_id)='" & qs!external_nmad_id & "'));"
Else:
Set StrSQL2 = CurrentDb.CreateQueryDef("", "SELECT RIGHT(IRSfileFormatKey, 10) As ID FROM 1042s_FinalOutput_7;")
Set ss = db.OpenRecordset("1042s_FinalOutput_7")
Set StrSQL2.Index = "ID"
StrSQL2.Seek "=", !external_nmad_id
If ss.NoMatch Then
DoCmd.RunSQL "INSERT INTO Addresses_NotUsed SELECT SunstarAccountsInWebir_SarahTest.* FROM SunstarAccountsInWebir_SarahTest WHERE (((SunstarAccountsInWebir_SarahTest.external_nmad_id)='" & qs!external_nmad_id & "'));"
Else: Set ss = db.OpenRecordset("1042s_FinalOutput_7")
ss.Edit
ss.Fields("box13c_Address") = qs.Fields("nmad_address_1") & qs.Fields("nmad_address_2") & qs.Fields("nmad_address_3")
ss.Update
End If
End If
qs.MoveNext
Next i
End With
'close reference set
qs.Close
Set qs = Nothing
ss.Close
Set ss = Nothing
End Sub
Consider a stripped down version of your code which still recreates the problem you're trying to solve.
Dim StrSQL2 As DAO.QueryDef
Set StrSQL2 = CurrentDb.CreateQueryDef("", "SELECT RIGHT(IRSfileFormatKey, 10) As ID FROM 1042s_FinalOutput_7;")
Set StrSQL2.Index = "ID"
When you attempt to run that code, Access will complain "Object doesn't support this property or method". The reason that happens is because StrSQL2 is a DAO.QueryDef and a QueryDef does not have an Index property. See QueryDef Members (DAO)
So then you disable that problem line and try this ...
StrSQL2.Seek "=", 27 'I substituted an arbitrary number for !external_nmad_id just to keep this simple '
But Access responds with the same complaint again, which is because a QueryDef does not have a Seek method.
Both Index and Seek are object members of a DAO.Recordset, so use them with a Recordset instead of a QueryDef
And if you go that route, designate the name of your controlling index like this ...
YourRecorsetVariable.Index = "ID"
Don't use Set there and make sure that "ID" is the name of the index ... which is not necessarily the name of the column which is indexed.
I am trying to delete duplicate records in MS ACCESS.
I have created a query that is sorted on field name.
I have VBA code that runs through the query, and then when finds a match it deletes the record - however it is not picking up the match.
My code looks as follows:
Dim db As DAO.Database
Dim recIn As DAO.Recordset
Dim strFieldName1 As Variant
Dim strFieldDescr2 As Variant
Dim strDomainCat3 As Variant
Dim strBusinessTerm4 As Variant
Dim strtableName5 As Variant
Dim lngRecordsDeleted As Variant
lngRecordsDeleted = 0
Set db = CurrentDb()
Set recIn = db.OpenRecordset("qryMyRecords")
If recIn.EOF Then
MsgBox ("No Input Records")
recIn.Close
Set recIn = Nothing
Set db = Nothing
Exit Sub
End If
Do
If recIn!FieldName = strFieldName1 And _
recIn!FieldDescr = strFieldDescr2 And _
recIn!DomainCatID = strDomainCat3 And _
recIn!BusinessTermID = strBusinessTerm4 And _
recIn!TableID = strtableName5 Then
recIn.Delete
lngRecordsDeleted = lngRecordsDeleted + 1
Else
strFieldName1 = recIn!FieldName
strFieldDescr2 = recIn!FieldDescr
strDomainCat3 = recIn!DomainCatID
strBusinessTerm4 = recIn!BusinessTermID
strtableName5 = recIn!TableID
End If
recIn.MoveNext
Loop Until recIn.EOF
recIn.Close
Set recIn = Nothing
Set db = Nothing
MsgBox ("You Deleted " & lngRecordsDeleted & " Records")
End Sub
My StrFieldname1, through to to StrTablename5 does populate (after the else statement)
However when I do the compare a second time
If recIn!FieldName = strFieldName1 And _
recIn!FieldDescr = strFieldDescr2 And _
recIn!DomainCatID = strDomainCat3 And _
recIn!BusinessTermID = strBusinessTerm4 And _
recIn!TableID = strtableName5 Then
recIn.Delete
lngRecordsDeleted = lngRecordsDeleted + 1
Even though the values are the same, it moves to the else statement, and never does the record delete.
Now I suspect that this could be because I declared my variables as VARIANT type, but if I use any other type, the code falls over every time it reaches a NULL value in the query, and there are cases where any of the fields from the query can and will be null.
Any suggestions would be greatly appreciated
To expand on what Justin said, use the Nz function in your main If statement, like so:
If Nz(recIn!FieldName, "") = strFieldName1 And _
...
Else
strFieldName1 = Nz(recIn!FieldName, "")
...
I've tried many different methods to join the following from;
StockCode Finished_Goods_Codes
100137 2105109
100137 2105110
100137 2105111
To;
StockCode Finished_Goods_Codes
100137 2105109, 2105110, 2105111
My Current Code is as follows;
Public Function ListQuery()
Dim curr As Database
Dim rs As Recordset
Dim SQLCmd As String
Dim productList As String
Set curr = CurrentDb()
SQLCmd = "SELECT Finished_Goods_Codes FROM TEMP_codes WHERE [StockCode] = """ & StockCode & """"
Set rs = curr.OpenRecordset(SQLCmd)
If Not rs.EOF Then
rs.MoveFirst
End If
Do While Not rs.EOF
productList = productList & rs(0) & ", "
rs.MoveNext
Loop
ListQuery = productList
End Function
My Query currently runs the following;
SELECT TEMP_codes.StockCode, ListQuery([Products]) AS [List of Products]
FROM TEMP_codes
GROUP BY TEMP_codes.StockCode;
Could you please help as i'm really stuck on this.
Many Thanks in advance.
Based on the answer given for the question Microsoft Access condense multiple lines in a table, here are the steps:
1 Create the following function
Public Function GetList(SQL As String _
, Optional ColumnDelimeter As String = ", " _
, Optional RowDelimeter As String = vbCrLf) As String
'PURPOSE: to return a combined string from the passed query
'ARGS:
' 1. SQL is a valid Select statement
' 2. ColumnDelimiter is the character(s) that separate each column
' 3. RowDelimiter is the character(s) that separate each row
'RETURN VAL: Concatenated list
'DESIGN NOTES:
'EXAMPLE CALL: =GetList("Select Col1,Col2 From Table1 Where Table1.Key = " & OuterTable.Key)
Const PROCNAME = "GetList"
Const adClipString = 2
Dim oConn As ADODB.Connection
Dim oRS As ADODB.Recordset
Dim sResult As String
On Error GoTo ProcErr
Set oConn = CurrentProject.Connection
Set oRS = oConn.Execute(SQL)
sResult = oRS.GetString(adClipString, -1, ColumnDelimeter, RowDelimeter)
If Right(sResult, Len(RowDelimeter)) = RowDelimeter Then
sResult = Mid$(sResult, 1, Len(sResult) - Len(RowDelimeter))
End If
GetList = sResult
oRS.Close
oConn.Close
CleanUp:
Set oRS = Nothing
Set oConn = Nothing
Exit Function
ProcErr:
' insert error handler
Resume CleanUp
End Function
2 Add a Reference for the function in the Module (Tools -> References). Add the Reference Micorosft ActiveX Data Objects 6.1 Library (or the most recent one available).
3 Save the Module with a name different from the function name, say Concatenation
4 Run the following query
SELECT T.StockCode, GetList("Select Finished_Goods_Codes From TEMP_codes As T1 Where T1.StockCode = " & [T].[StockCode],"",", ") AS Finished_Goods_Codes
FROM TEMP_codes AS T
GROUP BY T.StockCode;
Please forgive the sloppy coding, but I was thrown onto a project to get data from a spreadsheet to SQL server and the deadline has been missed. I was able to initial get my first dataswipe using a SELECT statement, but I can't seem to switch it over to an UPDATE.
Here's the code. I get the runtime error 3704 operation not allowed when object is closed at the line rstRecordset.AddNew
Public cnnConn As ADODB.Connection
Public rstRecordset As ADODB.Recordset
Public cmdCommand As ADODB.Command
Public Const Server As String = "datguy"
Public SQLQuery As String
Option Explicit
Sub testupinsertupdate()
Dim wkb As Workbook
Dim wks As Worksheet
Dim sel As Range
Set wkb = ActiveWorkbook
Set wks = Sheets(1)
Set sel = Selection
With wks
'Declaration unit
Dim dataitem As String
Dim yr As Integer
Dim yrmax As Integer
Dim rxcount As Integer
Dim row As Integer
Dim col As String
Dim cleanup As String
Dim sqlrxcount As String
dataitem = .Range("B3").Value
yr = 6 'data only needs to go back to 2006
yrmax = .Range("C7").End(xlToRight).row + yr 'declarative count to the Right-Of-File
rxcount = 7
row = .Range("A" & .Rows.Count).End(xlUp).row 'declarative count to EOF
col = .Range("C6").End(xlToRight).Column
cleanup = "Data Unavailable"
sqlrxcount = .Range("A" & rxcount).Value
Set cnnConn = New ADODB.Connection
cnnConn.ConnectionString = "driver={SQL Server};server=" & Server & ";database=database;Trusted_Connection=Yes"
cnnConn.ConnectionTimeout = 800
cnnConn.Open
For rxcount = 7 To row
Set cmdCommand = New ADODB.Command
Set cmdCommand.ActiveConnection = cnnConn
With cmdCommand
.CommandTimeout = 0
.CommandText = "UPDATE table SET " & dataitem & " = '" & Cells(col).Value & "' WHERE RX_ID = '" & sqlrxcount & "'"
.CommandType = adCmdText
.Execute
Debug.Print cmdCommand.State
End With
Debug.Print cmdCommand.State
Set rstRecordset = New ADODB.Recordset
Set rstRecordset.ActiveConnection = cnnConn
rstRecordset.Open cmdCommand, , adOpenStatic, adLockBatchOptimistic
col = ("C" & rxcount)
For yr = 6 To yrmax
rstRecordset.AddNew '*** error pops!
rstRecordset.Fields("RX_ID") = Range("A" & rxcount).Value
rstRecordset.Fields("YEAR_REPORTED") = yr + 2000
If Range(col).Value = cleanup Then
rstRecordset.Fields(dataitem) = Null
Else: rstRecordset.Fields(dataitem) = Range(col).Value
End If
'debug line to show results
Debug.Print Range("A" & rxcount).Value, yr + 2000, Range(col).Value
col = Range(col).Offset(0, 1).Address
Next yr
Next rxcount
rstRecordset.UpdateBatch
rstRecordset.Close
cnnConn.Close
End With
End Sub
I don't feel like I'm doing the operations in order, but I'm just trying to get the initial load and then will worry about maintenance later. Why isn't the object(I assume this is the recordset) open when it was opened three lines before?
You are attempting to open a recordset based on an update not a select
rstRecordset.Open cmdCommand, , adOpenStatic, adLockBatchOptimistic
should be something like
rstRecordset.Open "select * from table",cnnconn, adOpenStatic, adLockBatchOptimistic