I have a query table and transfer to excel. I loop from cell range to re-query into database and it works fine but it really take so much time since i used below code.. The code need to query and do recordset every time satified IF condition in each single cell. Is there other way that this code will execute in database server and once complete then, only do a recordset?
'Set Connection
Set Cn = CreateObject("ADODB.Connection")
Cn.Open "Driver={MySQL ODBC 5.3 ANSI Driver};Server=" & _
Server_Name & ";Port=" & Port & ";Database=" & Database_Name & _
";Uid=" & User_ID & ";Pwd=" & Password & ";"
'Set Recordset
Set rs = CreateObject("ADODB.Recordset")
rs.CursorLocation = 3
rs.Open SQLQuery, Cn, adOpenStatic
myArray = rs.GetRows()
kolumner = UBound(myArray, 1) 'Count number of Columns
rader = UBound(myArray, 2) 'count number of rows
For K = 0 To kolumner ' Using For loop data are displayed
Range("A5").Offset(0, K).Value = rs.Fields(K).Name 'Field is the header
of each column and not included in Array. Field(0) means header of first
column.
For R = 0 To rader
Range("A5").Offset(R + 1, K).Value = myArray(K, R)
Next
Next
set rows = 0 to rader
Range("L5").Value = "Debug Note" 'insert Name of Column
For R = 6 To 1100
Datevalue = Sheets("Sheet1").Range("I" & R)
Dateexcel = FORMAT(Datevalue, "yyyy-MM-dd HH:mm:ss")
SQLQuery2 = "SELECT * FROM Mfg.databasemodels_note " & _
"where typeId = " & Sheets("Sheet1").Range("B" & R) & " AND
date > " & "'" & Dateexcel & "'" & " order by date asc
limit 1;"
Set rs2 = CreateObject("ADODB.Recordset")
rs2.CursorLocation = 3 'client
rs2.Open SQLQuery2, Cn, adOpenStatic
myArray2 = rs2.GetRows()
If Not (rs2.BOF And rs2.EOF) And (Range("J" & R).Value = "failed" Or
Range("J" & R).Value = "invalid") Then
Range("L" & R).Value = myArray2(3, 0)
Else
End If
On Error Resume Next
rs2.Close
Set rs2 = Nothing
Next
Related
I am writing a macro by which I want to delete few names in column A of sheet 2 from the server table called login.
Database name is "my_db" and table name is login. I calling connection to connect to the server databse. Following is the complete code :-
Dim cnt As ADODB.Connection
Dim rst As ADODB.Recordset
Dim Sql As String
Sub Button1_Click()
Dim Ws As Worksheet
Dim Var As String
Dim i As Integer
i = 1
Set Ws = Worksheets("Sheet2")
Var = "login"
Sql = "name"
Call Connection
Do
Sql = " Delete From " & " " & Var & "" & " Where name" = "Ws.Cells(i, 1)"
Call Connection
i = i + 1
Loop Until Ws.Cells(i, 1) = ""
MsgBox "All entries deleted from login table"
End Sub
Dim strUserName As String
Dim strPassword As String
Dim ConnectString As String
Set cnt = New ADODB.Connection
strServerName = "localhost"
strDatabaseName = "my_db"
strUserName = "root"
strPassword = "root1"
ConnectString = "DRIVER={MySQL ODBC 5.1 Driver};" & _
"SERVER=" & strServerName & _
";DATABASE=" & strDatabaseName & ";" & _
"USER=" & strUserName & _
";PASSWORD=" & strPassword & _
";OPTION=3;"
With cnt
.CursorLocation = adUseClient
.Open ConnectString
.CommandTimeout = 0
Set rst = .Execute(Sql)
End With
'rst.Close
'cnt.Close
Set rst = Nothing
Set cnt = Nothing
End Sub
But the entries are not getting deleted. There is an error in SQL syntax, can anyone help me with the sql syntax ?
Sql = "delete From " & Var & " where name ='" & Ws.Cells(i, 1).Value & "'"
but it would be better to open the connection only once, run all the deletes, and then close the connection.
Also you don't need a recordset here (since you're not returning any records), so you can ignore the return value from cnt.Execute
Since you pasted the code only partially, I can only guess.
Do
Sql = " Delete From " & Var & " Where name" = "Ws.Cells(i, 1)"
Call Connection (Sql)
i = i + 1
Loop Until Ws.Cells(i, 1) = ""
Clean up your query. And more important pass it as a parameter to the connection.
I have very little experience with Access Databases however I have wrote a similar VBA macro in excel. I am trying to copy rows from one .mdb file into the exact same table on a different .mdb file. However I would like it to only import it if it does not already exsist. Could someone please advise me the best way to go about this and maybe some code I can use and modify? I have already looked around stack overflow and can't seem to find any examples that work.
There are 8 different tables and inside these a few hundred rows. with maybe 5-20 columns.
If the script could be made inside VBS this would be ideal, as it would allow me to run the updates without loading into access.
Thanks for any help or advice,
Simon
EDIT -
Zev's answer seems to do the job however I am getting this error, also the MDB inside site2 is the one I am copying from and putting it into site1
Error: Expected end of statement
Code: 800A0401
Line: 17
Char: 13
Code (saved as "update.vbs"):
Dim eng
Set eng = CreateObject("DAO.DBEngine.120")
Set dest = eng.OpenDatabase("C:\Users\simon\Documents\garden games redesign\import script\Site1\ActinicCatalog.mdb")
Sub CopyTable()
Dim rs
Set rs = dest.OpenRecordset("Person")
Dim sWhere
For Each fld In rs.Fields
sWhere = sWhere & " AND " & fld.Name & " <> t1." & fld.Name
Next
sWhere = Mid(sWhere, 6)
Dim sql: sql= _
"INSERT INTO Person " & _
"SELECT * " & _
"FROM Person AS t1 IN ""C:\Users\simon\Documents\garden games redesign\import script\Site2\ActinicCatalog.mdb"" " & _
"WHERE " & sWhere
dest.Execute(sql)
End Sub
Edit for more info:
\Site1\ActinicCatalog.mdb - is destination database
\Site2\ActinicCatalog.mdb - is original database
These databases have about 20 columns
Here is an example to get you started. It copies the content of [Table1] of the current database to [Table1] of a second database.
Option Compare Database
Option Explicit
Sub copyTables()
'Open source database
Dim dSource As Database
Set dSource = CurrentDb
'Open dest database
Dim dDest As Database
Set dDest = DAO.OpenDatabase("C:\Users\Admin\Desktop\DBdest.accdb")
'Open source recordset
Dim rSource As Recordset
Set rSource = dSource.OpenRecordset("Table1", dbOpenForwardOnly)
'Open dest recordset
Dim rDest As Recordset
Set rDest = dDest.OpenRecordset("Table1", dbOpenDynaset)
'Loop through source recordset
While Not rSource.EOF
'Look for record in dest recordset
rDest.FindFirst _
"Field1 = '" & rSource.Fields("Field1") & "' AND " & _
"Field2 = " & rSource.Fields("Field2")
'If not found, copy record - Field1 is text / Field2 is numeric
If rDest.NoMatch Then
rDest.AddNew
rDest.Fields("Field1") = rSource.Fields("Field1")
rDest.Fields("Field2") = rSource.Fields("Field2")
rDest.Update
End If
'Next source record
rSource.MoveNext
Wend
'Close dest recordset
rDest.Close
Set rDest = Nothing
'Close source recordset
rSource.Close
Set rSource = Nothing
'Close dest database
dDest.Close
Set dDest = Nothing
'Close source database
dSource.Close
Set dSource = Nothing
End Sub
I would suggest using an SQL statement if possible. From VBScript using DAO/ACE:
Dim eng
Set eng = CreateObject("DAO.DBEngine.120")
Set dest = eng.OpenDatabase("path\to\destination\database.accdb")
Using ADO:
Dim conn
Set conn = CreateObject("ADODB.Connection")
With conn
.Provider = "Microsoft.ACE.OLEDB.12.0"
.ConnectionString = "Data Source=""path\to\destination\database.accdb"";"
.Open
End With
The SQL statement would be something like this:
INSERT INTO Table1
SELECT *
FROM Table1 AS t1 IN "path\to\source\database.accdb"
WHERE Table1.Field1 <> t1.Field1
and executed like this:
Dim sql = _
"INSERT INTO Table1 " & _
"SELECT * " & _
"FROM Table1 AS t1 IN "path\to\source\database.accdb" " & _
"WHERE Table1.Field1 <> t1.Field1"
'Using DAO or ADO
dest.Execute sql
Considering that each table has a variable number of columns, you might have to generate the WHERE expression dynamically:
Sub CopyTable(tablename)
Dim rs
Set rs = dest.OpenRecordset(tablename)
'if using ADO:
'Set rs = conn.Execute(tablename)
Dim sWhere
For Each fld In rs.Fields
sWhere = sWhere & " AND " & fld.Name & " <> t1." & fld.Name
Next
sWhere = Mid(sWhere, 6)
Dim sql
sql = _
"INSERT INTO " & tablename & " " & _
"SELECT * " & _
"FROM " & tablename & " AS t1 IN ""path\to\source\database.accdb"" " & _
"WHERE " & sWhere
dest.Execute(sql)
End Sub
Update
If you are only using one column to determine whether the record exists, the SQL statement should look like this:
INSERT INTO Table1
SELECT *
FROM Table1 AS t1 IN "path\to\source\database.accdb"
LEFT JOIN Table1 ON t1.FirstField = Table1.FirstField
WHERE Table1.FirstField IS NULL
and CopyTable like this:
Sub CopyTable(tablename)
Dim rs
Set rs = dest.OpenRecordset(tablename)
'if using ADO:
'Set rs = conn.Execute(tablename)
Dim field0Name
field0Name=rs.Fields(0).Name
Dim sql
sql = _
"INSERT INTO " & tablename & " " & _
"SELECT * " & _
"FROM " & tablename & " AS t1 IN ""path\to\source\database.accdb"" " & _
"LEFT JOIN " & tablename & " ON t1." & field0Name & "=" & tablename & "." & field0Name & " " & _
"WHERE " & tablename & "." & field0Name & " IS NULL"
dest.Execute(sql)
End Sub
I've been using stackoverflow for over a year now but this is my first post so if I do something wrong, please let me know and I'll try to do better next time.
I'm currently using MS Access 2003 as a front-end data entry application with an MS SQL 2008 back end. A function used by just about every form in the app is breaking for no reason that I can determine when called from a specific subroutine.
Calling subroutine:
Private Sub Form_Load()
strRep = GetAppCtl("ConUID")
FLCnnStr = GetAppCtl("ConStrApp")
strSQL2 = "SELECT EMPNMBR, First, Last, TSLogin, IsITAdmin, " & _
" IsManager, Pwd, AppAuthLvl, SEX, AppTimeOutMins " & _
" FROM utEmplList WHERE EMPNMBR = " & _
strRep & ";"
Set cnn = New ADODB.Connection
With cnn
.ConnectionString = FLCnnStr
.Open
End With
Set rst = New ADODB.Recordset
rst.Open strSQL2, cnn, adOpenDynamic, adLockReadOnly
intAppAuthLvl = rst!AppAuthLvl
' Loaded/opened with parameters / arguments (OpenArgs)?
If Not IsNull(Me.OpenArgs) And Me.OpenArgs <> "" Then
Me.txtEmpSecLvl = Me.OpenArgs
Else
Me.txtEmpSecLvl = "99999<PROGRAMMER>Login:-1,-1\PWD/999|M!60$"
End If
Me.lblDateTime.Caption = Format(Now, "dddd, mmm d yyyy hh:mm AMPM")
If FirstTime <> "N" Then
' Set default SQL select statement with dummy WHERE clause
' (DealID will always be <> 0!)
strDate = DateAdd("d", -14, Now())
strSQLdefault1 = "SELECT *, DealHasTags([PHONE10],[REP]) as DealHasTags FROM utDealSheet WHERE DealID <> 0 AND (STATUS BETWEEN '00' AND '99') "
strSQLdefault2 = "SELECT *, DealHasTags([PHONE10],[REP]) as DealHasTags FROM utDealSheet WHERE DATE >= #" & strDate & "# AND DealID <> 0 AND (STATUS BETWEEN '00' AND '99') "
Me.LoggingDetail.Enabled = False
Me.LoggingDetail.Visible = False
If rst!AppAuthLvl <= 200 Then
strSQL = strSQLdefault1 & ";"
Me.LoggingDetail.Form.RecordSource = strSQL
Else
strSQL = strSQLdefault2 & ";"
Me.LoggingDetail.Form.RecordSource = strSQL
End If
FirstTime = "N"
End If
DoCmd.Maximize
End Sub
Function that is breaking:
Public Function GetAppCtl(strFldDta As String) As Variant
Dim strSQL As String
Dim cnn As ADODB.Connection
Dim rst As ADODB.Recordset
Dim strConnString As String
If IsNull(strFldDta) Then GetAppCtl = "ERR"
' Starting string
strConnString = "ODBC;Description=SQLUmgAgr;DRIVER=SQL Server;SERVER="
' Set a connection object to the current Db (project)
Set cnn = CurrentProject.Connection
strSQL = "Select ConStrApp, ConStrTS, DftOfficeID, RecID, VerRelBld, SeqPrefix, ConDb, ConDbTs, ConUID, ConUIDTS, ConPWD, ConPWDTs, ConServer, ConServerTS, ConWSID, ConWSIDTS from tblAppCtl WHERE RecID = 1;"
Set rst = New ADODB.Recordset
rst.Open strSQL, cnn, adOpenKeyset, adLockReadOnly
' If a Db error, return 0
If Err.Number <> 0 Then
GetAppCtl = ""
GoTo CleanUp
End If
' If no record found, return 0
If rst.EOF Then
GetAppCtl = ""
Else ' Otherwise, return Version/Build
Select Case strFldDta
Case Is = "ConStrApp" ' connection string - application
strConnString = strConnString & Trim(rst!Conserver) & ";" _
& "UID=" & Trim(rst!ConUID) & ";PWD=" & Trim(rst!conpwd) & ";" _
& "DATABASE=" & Trim(rst!ConDb) & ";WSID=" & Trim(rst!ConWSID)
GetAppCtl = strConnString
Case Is = "ConStrTS" ' connection string - TouchStar
strConnString = strConnString & Trim(rst!ConserverTS) & ";" _
& "UID=" & Trim(rst!ConUIDTS) & ";PWD=" & Trim(rst!conpwdTS) & ";" _
& "DATABASE=" & Trim(rst!ConDbTS) & ";WSID=" & Trim(rst!ConWSID)
GetAppCtl = strConnString
Case Is = "DftOfficeID" ' Default AGR office ID
GetAppCtl = rst!DftOfficeID
Case Is = "VerRelBld" ' Current APP ver/rel/bld (to be checked against SQL Db
GetAppCtl = rst!VerRelBld
Case Is = "SeqPreFix" ' Sales seq# prefix (ID as per office for backward capability)
GetAppCtl = rst!SeqPrefix
Case Is = "ConUID"
GetAppCtl = rst!ConUID
End Select
End If
CleanUp:
rst.Close
Set rst = Nothing
cnn.Close
Set cnn = Nothing
End Function
The function is breaking here, but only when called by the above sub:
Set rst = New ADODB.Recordset
rst.Open strSQL, cnn, adOpenKeyset, adLockReadOnly
' If a Db error, return 0
If Err.Number <> 0 Then
GetAppCtl = ""
GoTo CleanUp
End If
When called from any other sub it works fine and returns the appropriate value. Please help.
I don't have an actual explanation as to why it was returning an error code but by removing the error checking the process worked. If anyone has an actual explanation as to what was actually causing the issue it would be greatly appreciated.
I know this post's a bit old and OP might have solved the problem.
I encountered the same problem and solved it by changing "Microsoft ActiveX Data Objects 2.5 Library" to "Microsoft ActiveX Data Objects 2.8 Library" from VBA Tools => References.
There's a csv file like so, I can read it easily enough with the code below. But as you can see there are multiple name1, group1, status1, name2, group2, etc columns in the csv. Each user will have a different number of columns. I was wondering if there is a way to use wild cards where I'm calling objRecordset.Fields.Item("Group1") something like ("Group%") or if I can auto increment the number until no records are found
UserName,Domain,Site,MCO,Name1,Group1,Status1,Name2,Group2,Status2,Name3,Group3,Status3
Paolina,AA,Athens,Greece,Adobe Acrobat Pro,ACROBAT009,Live,,,,,,
George,AA,Athens,Greece,SpotFire 2.20,SPOTFIRE220,Live,,,,,,
option explicit
Const adOpenStatic = 3
Const adLockOptimistic = 3
Const adCmdText = &H0001
Dim strPathtoTextFile, objConnection, objRecordSet, objNetwork
Dim wshshell, Username
Set objConnection = CreateObject("ADODB.Connection")
Set objRecordSet = CreateObject("ADODB.Recordset")
Set objNetwork = CreateObject("WScript.Network")
userName = objNetwork.UserName
strPathtoTextFile = "C:\Hunter\vbs\" 'must have a trailing \
objConnection.Open "Provider=Microsoft.Jet.OLEDB.4.0;" & _
"Data Source=" & strPathtoTextFile & ";" & _
"Extended Properties=""text;HDR=YES;FMT=Delimited"""
objRecordset.Open "SELECT * FROM Users.txt where [user name] like '" & UserName & "'", _
objConnection, adOpenStatic, adLockOptimistic, adCmdText
Do Until objRecordset.EOF
Wscript.Echo "Name: " & objRecordset.Fields.Item("User Name")
Wscript.Echo "Group: " & objRecordset.Fields.Item("Group1")
Wscript.echo "Status:" & objRecordset.Fields.Item("Status1")
objRecordSet.MoveNext
Loop
Your example suggests that the maximum group number is the last field, so perhaps:
objRecordset.Open "SELECT * FROM Users.txt where [user name] like '" _
& UserName & "'", _
objConnection, adOpenStatic, adLockOptimistic, adCmdText
MaxNum = _
Replace(objRecordset.Fields(objRecordset.Fields.Count-1).Name,"Status","")
Do Until objRecordset.EOF
Wscript.Echo "Name: " & objRecordset.Fields.Item("User Name")
For i=1 to MaxNum
Wscript.Echo "Group: " & objRecordset.Fields.Item("Group" & i)
Wscript.echo "Status:" & objRecordset.Fields.Item("Status" & i)
Next
objRecordSet.MoveNext
Loop
I have not tested, but the general idea should hold.
I am creating a macro to add data from my Excel sheet into my MySQL Database
But when I run the Macro I am getting Error:
[Microsoft][ODBC Manager] Data source name not found and no default driver specified
Code:
Sub UpdateMySQLDatabasePHP()
' For detailed description visit http://www.vbaexcel.eu/
Dim Cn As ADODB.Connection
Dim Server_Name As String
Dim Database_Name As String
Dim User_ID As String
Dim Password As String
Dim SQLStr As String
Dim rs As ADODB.Recordset
Set rs = New ADODB.Recordset
Server_Name = Range("e4").Value ' IP number or servername
Database_Name = Range("e1").Value ' Name of database
User_ID = Range("h1").Value 'id user or username
Password = Range("e3").Value 'Password
Tabellen = Range("e2").Value ' Name of table to write to
rad = 0
While Range("a6").Offset(rad, 0).Value <> tom
TextStrang = tom
kolumn = 0
While Range("A5").Offset(0, kolumn).Value <> tom
If kolumn = 0 Then TextStrang = TextStrang & Cells(5, 1) & " = '" & Cells(6 + rad, 1)
If kolumn <> 0 Then TextStrang = TextStrang & "', " & Cells(5, 1 + kolumn) & " = '" & Cells(6 + rad, 1 + kolumn)
kolumn = kolumn + 1
Wend
TextStrang = TextStrang & "'"
field2 = "cid"
field1 = "bid"
table1 = "MMbanner"
SQLStr = "UPDATE " & Tabellen & " SET " & TextStrang & "WHERE " & Cells(5, 1) & " = '" & Cells(6 + rad, 1) & "'"
Set Cn = New ADODB.Connection
Cn.Open "Driver={MySQL ODBC 3.51 Driver};Server=" & Server_Name & ";Database=" & Database_Name & _
";Uid=" & User_ID & ";Pwd=" & Password & ";"
Cn.Execute SQLStr
rad = rad + 1
Wend
Set rs = Nothing
Cn.Close
Set Cn = Nothing
End Sub
It looks as though there is something wrong with the connection string. do you have the mySQL odbc driver installed?
the easiest way I have found to test connections is to create a text file "New Text Document.txt" and renaming the file extension to udl so you end up with "New Text Document.udl" then open the file. It should show you the Datalink proerties wizard. you can then go through the wizard to create and test the connection. to get the connection string. either open the ".udl" file with notepad or change the extension back to ".txt" and open it with notepad.