I have some data in Excel that needs to be updated into a linked table in MS access. The link table connects to a sharepoint site. The code I have so far only works with regular table. rs.Open returns unspecified error in this case.
Sub Button1_Click()
On Error GoTo ExceptionHandle
Dim cn As ADODB.Connection, rs As ADODB.Recordset
' connect to the Access database
Set cn = New ADODB.Connection
cn.Open "Provider=Microsoft.Jet.OLEDB.4.0; " & _
"Data Source=D:\.....\db1.mdb;"
' open a recordset
Set rs = New ADODB.Recordset
'ERROR
rs.Open "LinkedTableName", cn, adOpenKeyset, adLockOptimistic, adCmdTable
Range("B2").Activate ' row 1 contains column headings
Do While Not IsEmpty(ActiveCell)
s_title = ActiveCell.Offset.Value
s_start_time = ActiveCell.Offset(0, 1).Value
s_end_time = ActiveCell.Offset(0, 2).Value
rs.Filter = "Title ='" & s_title & "'"
If rs.EOF Then
Debug.Print "No existing record - adding new..."
rs.Filter = ""
rs.AddNew
Else
Debug.Print "Existing record found..."
End If
rs("Title").Value = s_title
rs("Start Time").Value = s_start_time
rs("End Time").Value = s_end_time
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
ExitProcedure:
MsgBox "Update success"
Exit Sub
ExceptionHandle:
MsgBox "Error:" & Err.Number & ": " & Err.Description
Exit Sub
End Sub
Related
I have used below code but failed at step
ActiveWorkbook.Sheets("Sheet1").Cells.CopyFromRecordset rs
Can anyone help to check why?
Sub get_Data_From_DB()
Dim cnn As ADODB.Connection
Set cnn = New ADODB.Connection
' Open a connection by referencing the ODBC driver.
cnn.ConnectionString = "driver={SQL Server};" & _
"server=aaaaa,2431;uid=bbb;pwd=ccc;database=ddd"
cnn.Open
' Find out if the attempt to connect worked.
If cnn.State = adStateOpen Then
MsgBox "Welcome to Pubs!"
Sql = "SELECT top 10 * from tableA(NOLOCK)"
Set rs = cnn.Execute(Sql)
ActiveWorkbook.Sheets("Sheet1").Cells.CopyFromRecordset rs
Else
MsgBox "Sorry. No Pubs today."
End If
' Close the connection.
cnn.Close
End Sub
Change this:
ActiveWorkbook.Sheets("Sheet1").Cells.CopyFromRecordset rs
To something like this:
ActiveWorkbook.Sheets("Sheet1").Range("A1").CopyFromRecordset rs
You can change "A1" to another cell if you'd like.
EDIT: Here's how I'd actually organize this to make it flexible/reusable.
Sub runPubsQuery
Dim sqlStr As String
sqlStr = "SELECT top 10 * FROM tableA(NOLOCK)"
Call writeSqlResults(sqlStr,getConnectionString(),ThisWorkbook.Sheets("Sheet1"))
End Sub
Sub writeSQLResults(sqlStr As String, connStr As String, destWS As Worksheet, _
Optional errMsg As String = "Sorry. No Pubs today.", Optional welcMsg As String = "Welcome to Pubs!")
Dim cn As New ADODB.Connection
Dim rs As New ADODB.Recordset
Dim headerArr As Variant
cn.Open (connStr)
If Not cn.State = adStateOpen Then
MsgBox errMsg
Else
MsgBox welcMsg
Set rs = cn.Execute(sqlStr)
If Not rs.EOF Then
headerArr = getRecordHeaders(rs)
With destWS
.Cells.Clear
.Range(.Cells(1, 1), .Cells(1, UBound(headerArr, 2))).Value = headerArr
.Range("A2").CopyFromRecordset rs
End With
rs.Close
End If
End If
cn.Close
End Sub
Function getConnectionString(Optional serverName As String = "aaaa,2431", Optional dbName As String = "ddd", _
Optional uidStr As String = "bbb", Optional pwdStr As String = "ccc") As String
getConnectionString = "Driver={SQL Server};" & _
"Server=" & serverName & ";" & _
"Uid=" & uidStr & ";" & _
"Pwd=" & pwdStr & ";" & _
"Database=" & dbName & ";"
End Function
Function getRecordHeaders(rs As Variant) As Variant
If Not TypeName(rs) = "Recordset" Then
MsgBox "Error: Parameter rs is not a valid recordset"
Stop
Exit Function
End If
Dim i As Long
Dim j As Long
If Not rs.EOF Then
ReDim headerArr(1 To 1, 1 To rs.Fields.Count) As Variant
j = 0
For i = LBound(headerArr, 2) To UBound(headerArr, 2)
headerArr(1, i) = rs.Fields(j).Name
j = j + 1
Next
getRecordHeaders = headerArr
Else
MsgBox "Error: Recordset is empty"
Stop
Exit Function
End If
End Function
This is how I would do it, to get all field naems and all records as well.
Sub ADOExcelSQLServer()
' Carl SQL Server Connection
'
' FOR THIS CODE TO WORK
' In VBE you need to go Tools References and check Microsoft Active X Data Objects 2.x library
'
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 = "Your_Server_NameS" ' Enter your server name here
Database_Name = "Your_DB_Name" ' Enter your database name here
User_ID = "" ' enter your user ID here
Password = "" ' Enter your password here
SQLStr = "SELECT * FROM [Customers]" ' Enter your SQL here
Set Cn = New ADODB.Connection
Cn.Open "Driver={SQL Server};Server=" & Server_Name & ";Database=" & Database_Name & _
";Uid=" & User_ID & ";Pwd=" & Password & ";"
rs.Open SQLStr, Cn, adOpenStatic
' Dump to spreadsheet
For iCols = 0 To rs.Fields.Count - 1
Worksheets("Sheet1").Cells(1, iCols + 1).Value = rs.Fields(iCols).Name
Next
With Worksheets("sheet1").Range("a2:z500") ' Enter your sheet name and range here
'.ClearContents
.CopyFromRecordset rs
End With
' Tidy up
rs.Close
Set rs = Nothing
Cn.Close
Set Cn = Nothing
End Sub
I am having trouble when getting data from SQL Server. Here is the code.
Private Sub Form_Load()
Dim blsCritical As Boolean
'----------------------------------------------
ListBox.AddItem "Initializing..."
'----------------------------------------------
Me.Repaint
'----------------------------------------------
ListBox.AddItem "Welcome"
'----------------------------------------------
Me.Repaint
'----------------------------------------------
ListBox.AddItem "Examining your access rights..."
Call ConnectSQLServer
'----------------------------------------------
Me.Repaint
ListBox.AddItem strSQL
'----------------------------------------------
ListBox.AddItem "Opening database connection..."
'----------------------------------------------
Me.Repaint
End Sub
Sub ConnectSQLServer()
Dim cmd As ADODB.Command
Dim conn As ADODB.Connection
Dim strConn As String
Dim par As ADODB.Parameter
Set objMyConn = New ADODB.Connection
Set objMyRecordset = New ADODB.Recordset
Dim strSQL As String
objMyConn.ConnectionString = "DRIVER=SQL Server;SERVER=CHU-AS-0004;DATABASE=RTC_LaplaceD_DEV;Trusted_Connection=Yes;"
objMyConn.Open
strSQL = "SELECT [currentVersion], [standardVersion] FROM [dbo].[Version]"
If currentVersion = "" Then
MsgBox ("No currentVersion value")
ElseIf Not IsNull(currentVersion) Then
If currentVersion < standardVersion Then
MsgBox ("Upgrade is needed")
ElseIf currentVersion = standardVersion Then
MsgBox ("PASS")
Else
End If
Else
End If
Set objMyRecordset.ActiveConnection = objMyConn
objMyRecordset.Open strSQL
End Sub
I have data in SQL Server:
but I cannot get data from SQL Server. When I execute it, 'No CurrentVersion value' message pops up. I don't see any mistakes in my code. Could you help me to solve this problem?(It would be great if you can share your fixed code...)
Just whipped this up for you to show you where you went wrong... untested...
strSQL = "SELECT [currentVersion], [standardVersion] FROM [dbo].[Version]"
Set objMyRecordset.ActiveConnection = objMyConn
objMyRecordset.Open strSQL
while objMyRecordset.EOF = false
currentVersion = objMyRecordset!currentVersion
objMyRecordset.MoveNext
wend
If currentVersion = "" Then
MsgBox ("No currentVersion value")
ElseIf Not IsNull(currentVersion) Then
If currentVersion < standardVersion Then
MsgBox ("Upgrade is needed")
ElseIf currentVersion = standardVersion Then
MsgBox ("PASS")
Else
End If
Else
End If
Something like this should do the job.
Sub GetDataFromADO()
'Declare variables'
Set objMyconn = New ADODB.Connection
Set objMyCmd = New ADODB.Command
Set objMyRecordset = New ADODB.Recordset
Dim rc As Long
'Open Connection'
objMyconn.ConnectionString = "Provider=SQLOLEDB;Data Source=SAXAM\SQLEXPRESS;Initial Catalog=AdventureWorks2012; Integrated Security=SSPI;"
objMyconn.Open
'Set and Excecute SQL Command'
Set objMyCmd.ActiveConnection = objMyconn
objMyCmd.CommandText = "select * from [Person].[BusinessEntity] "
objMyCmd.CommandType = adCmdText
objMyCmd.Execute
'Open Recordset'
Set objMyRecordset.ActiveConnection = objMyconn
objMyRecordset.Open objMyCmd
'Copy Data to Excel'
'ActiveSheet.Range("A1").CopyFromRecordset (objMyRecordset)
Application.ActiveCell.CopyFromRecordset (objMyRecordset)
rc = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row
ActiveSheet.Cells(rc + 1, 1).Select
'Worksheets("Sheet1").Cells(Rows.Count, 1).End(xlUp).Value
objMyconn.Close
End Sub
Here's one more idea. Let's say you had a bunch of Select statements in a bunch of cells from A1, down to whatever, you can add sheets dynamically, and import some sample data on to each sheet, to get a sense of the data structures of multiple tables.
Assuming the following in A1:A3.
SELECT TOP 1000 * FROM [YOUR_DB].[dbo].[YOUR_TABLE1]
SELECT TOP 1000 * FROM [YOUR_DB].[dbo].[YOUR_TABLE2]
SELECT TOP 1000 * FROM [YOUR_DB].[dbo].[YOUR_TABLE3]
Run the script below.
Sub Download_From_Multiple_Tables()
'Initializes variables
Dim cnn As New ADODB.Connection
Dim rst As New ADODB.Recordset
Dim ConnectionString As String
Dim StrQuery As String
Dim rCell As Range
Dim rRng As Range
Dim sht As Worksheet
Dim LastRow As Long
Set cnn = New ADODB.Connection
'For a trusted Connection, where your user ID has permissions on the SQL Server:
cnn.Open ConnectionString:="Provider=SQLOLEDB.1;" & _
"Data Source=" & "YOUR_SERVER_NAME" & ";Initial Catalog=" & "YOUR_DB_NAME" & _
";TRUSTED_CONNECTION=YES"
'Opens connection to the database
'Timeout error in seconds for executing the entire query; this will run for 15 minutes before VBA timesout, but your database might timeout before this value
cnn.CommandTimeout = 900
Set sht = ThisWorkbook.Worksheets("Sheet1")
'Ctrl + Shift + End
LRow = sht.Cells(sht.Rows.Count, "A").End(xlUp).Row
Set rRng = Sheet1.Range("A1:A" & LRow)
i = 2
For Each rCell In rRng.Cells
LPosition = InStrRev(rCell.Value, "[dbo]") + 5
' Name the newly added worksheet, based on the cell value
Name = Mid(rCell.Value, LPosition + 1, 99)
' Remove [] characters, as these are not permitted in tab names
Name = Replace(Name, "[", "")
Name = Replace(Name, "]", "")
SheetName = Left(Name, 31)
Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = SheetName
Worksheets(SheetName).Activate
StrQuery = rCell.Value
'Performs the actual query
rst.Open StrQuery, cnn
'Dumps all the results from the StrQuery into cell A2 of the first sheet in the active workbook
' Dump field names to the worksheet
For intFieldIndex = 0 To rst.Fields.Count - 1
ActiveSheet.Cells(1, intFieldIndex + 1).Value = rst.Fields(intFieldIndex).Name
Next intFieldIndex
' Dump the records to the worksheet
ActiveSheet.Cells(2, 1).CopyFromRecordset rst
' Sheets(i).Range("A1").CopyFromRecordset rst
i = i + 1
rst.Close
Next rCell
End Sub
I have large data in Excel that I need to upload to SQL Server but I am using Access as a Front End. Number of columns in Excel are around 90 and number of records goes above 700,000
I just answered a question like this about an hour ago.
Sub Button_Click()
'TRUSTED CONNECTION
On Error GoTo errH
Dim con As New ADODB.Connection
Dim rs As New ADODB.Recordset
Dim strPath As String
Dim intImportRow As Integer
Dim strFirstName, strLastName As String
Dim server, username, password, table, database As String
With Sheets("Sheet1")
server = .TextBox1.Text
table = .TextBox4.Text
database = .TextBox5.Text
If con.State <> 1 Then
con.Open "Provider=SQLOLEDB;Data Source=" & server & ";Initial Catalog=" & database & ";Integrated Security=SSPI;"
'con.Open
End If
'this is the TRUSTED connection string
Set rs.ActiveConnection = con
'delete all records first if checkbox checked
If .CheckBox1 Then
con.Execute "delete from tbl_demo"
End If
'set first row with records to import
'you could also just loop thru a range if you want.
intImportRow = 10
Do Until .Cells(intImportRow, 1) = ""
strFirstName = .Cells(intImportRow, 1)
strLastName = .Cells(intImportRow, 2)
'insert row into database
con.Execute "insert into tbl_demo (firstname, lastname) values ('" & strFirstName & "', '" & strLastName & "')"
intImportRow = intImportRow + 1
Loop
MsgBox "Done importing", vbInformation
con.Close
Set con = Nothing
End With
Exit Sub
errH:
MsgBox Err.Description
End Sub
Also, check out these links.
https://www.excel-sql-server.com/excel-sql-server-import-export-using-vba.htm
http://tomaslind.net/2013/12/26/export-data-excel-to-sql-server/
I need to insert test-vba.xlsx data into SQL server to the particular database
Sub insertion()
Dim conn As ADODB.Connection
Dim rs As ADODB.Recordset
Dim sConnString As String
Dim rsstring As String
Dim m, nrows As Integer
Set wkb = Workbooks("test-vba.xlsx").Worksheets("Sheet1").Activate
sConnString = "Provider=SQLOLEDB;Data Source=PRATEEP-PC\SQLEXPRESS;" & _
"Initial Catalog=PPDS_07Dec_V1_Decomposition;" & _
"Integrated Security=SSPI;"
Set conn = New ADODB.Connection
Set rs = New ADODB.Recordset
conn.Open sConnString
For m = 0 To nrows - 1
Here are a couple ideas.
Sub UpdateTable()
Dim cnn As Object
Dim wbkOpen As Workbook
Dim objfl As Variant
Dim rngName As Range
Workbooks.Open "C:\Users\Excel\Desktop\Excel_to_SQL_Server.xls"
Set wbkOpen = ActiveWorkbook
Sheets("Sheet1").Select
Set rngName = Range(Range("A1"), Range("A1").End(xlToLeft).End(xlDown))
rngName.Name = "TempRange"
strFileName = wbkOpen.FullName
Set cnn = CreateObject("ADODB.Connection")
cnn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & strFileName & ";Extended Properties=""Excel 12.0 Xml;HDR=Yes"";"
nSQL = "INSERT INTO [odbc;Driver={SQL Server};Server=Server_Name;Database=[Database_Name].[dbo].[TBL]]"
nJOIN = " SELECT * from [TempRange]"
cnn.Execute nSQL & nJOIN
MsgBox "Uploaded Successfully"
wbkOpen.Close
Set wbkOpen = Nothing
End Sub
Sub InsertInto()
'Declare some variables
Dim cnn As adodb.Connection
Dim cmd As adodb.Command
Dim strSQL As String
'Create a new Connection object
Set cnn = New adodb.Connection
'Set the connection string
cnn.ConnectionString = "Server_Name;Database=Database_Name;Trusted_Connection=True;"
'Create a new Command object
Set cmd = New adodb.Command
'Open the connection
cnn.Open
'Associate the command with the connection
cmd.ActiveConnection = cnn
'Tell the Command we are giving it a bit of SQL to run, not a stored procedure
cmd.CommandType = adCmdText
'Create the SQL
strSQL = "UPDATE TBL SET JOIN_DT = 2013-01-13 WHERE EMPID = 2"
'Pass the SQL to the Command object
cmd.CommandText = strSQL
'Open the Connection to the database
cnn.Open
'Execute the bit of SQL to update the database
cmd.Execute
'Close the connection again
cnn.Close
'Remove the objects
Set cmd = Nothing
Set cnn = Nothing
End Sub
Here is another idea.
Sub Button_Click()
'TRUSTED CONNECTION
On Error GoTo errH
Dim con As New ADODB.Connection
Dim rs As New ADODB.Recordset
Dim strPath As String
Dim intImportRow As Integer
Dim strFirstName, strLastName As String
Dim server, username, password, table, database As String
With Sheets("Sheet1")
server = .TextBox1.Text
table = .TextBox4.Text
database = .TextBox5.Text
If con.State <> 1 Then
con.Open "Provider=SQLOLEDB;Data Source=" & server & ";Initial Catalog=" & database & ";Integrated Security=SSPI;"
'con.Open
End If
'this is the TRUSTED connection string
Set rs.ActiveConnection = con
'delete all records first if checkbox checked
If .CheckBox1 Then
con.Execute "delete from tbl_demo"
End If
'set first row with records to import
'you could also just loop thru a range if you want.
intImportRow = 10
Do Until .Cells(intImportRow, 1) = ""
strFirstName = .Cells(intImportRow, 1)
strLastName = .Cells(intImportRow, 2)
'insert row into database
con.Execute "insert into tbl_demo (firstname, lastname) values ('" & strFirstName & "', '" & strLastName & "')"
intImportRow = intImportRow + 1
Loop
MsgBox "Done importing", vbInformation
con.Close
Set con = Nothing
End With
Exit Sub
errH:
MsgBox Err.Description
End Sub
Also, check out the links below.
http://www.cnblogs.com/anorthwolf/archive/2012/04/25/2470250.html
http://www.excel-sql-server.com/excel-sql-server-import-export-using-vba.htm
I'm trying to loop through excel cells to get value from sql server table. I've written a macro that will take the jobnumber from the excel and query sql server tale to get customer details and dump it on the spreadsheet. So far I'm only able to get data for single cell. How can I loop through the excel cells for more than one jobnumber. I'm new to VBA. Thanks for your help. Here is my macro:
Sub ConnectSqlServer()
Dim conn As ADODB.Connection
Dim rs As ADODB.Recordset
Dim sConnString As String
Dim newrow As String
newrow = Worksheets("Sheet1").Cells(1, "A").Value
' Create the connection string.
sConnString = "Provider=SQLOLEDB;Data Source=0.0.0.0;" & _
"Initial Catalog=asset;" & _
"User ID=Temp;Password=test123;"
' Create the Connection and Recordset objects.
Set conn = New ADODB.Connection
Set rs = New ADODB.Recordset
' Open the connection and execute.
conn.Open sConnString
Set rs = conn.Execute("SELECT customer FROM job_tab where jobnum2='" & Trim(newrow) & "';")
' Check we have data.
If Not rs.EOF Then
' Transfer result.
Sheets(1).Range("B1").CopyFromRecordset rs
' Close the recordset
rs.Close
Else
MsgBox "Error: No records returned.", vbCritical
End If
' Clean up
If CBool(conn.State And adStateOpen) Then conn.Close
Set conn = Nothing
Set rs = Nothing
End Sub
You can do so, by using the IN SQL statement:
SELECT customer FROM job_tab WHERE jobnum2 IN ( 'Value1', 'Value2', ... );
Therefore you have to loop through all the customers in column A of your table and alter the SQL request to use the above mentioned statement:
Sub ConnectSqlServer()
Dim conn As ADODB.Connection
Dim rs As ADODB.Recordset
Dim sConnString As String
Dim newrow As String
'MODIFIED: create the search string for the IN-Statement
newrow = "("
For i = 1 To Worksheets("Sheet1").Cells(Worksheets("Sheet1").Rows.Count, "A").End(xlUp).Row
newrow = newrow & "'" & Trim(Worksheets("Sheet1").Cells(i, "A").value) & "',"
Next i
newrow = Left(newrow, Len(newrow) - 1)
newrow = newrow & ")"
' Create the connection string.
sConnString = "Provider=SQLOLEDB;Data Source=0.0.0.0;" & _
"Initial Catalog=asset;" & _
"User ID=Temp;Password=test123;"
' Create the Connection and Recordset objects.
Set conn = New ADODB.Connection
Set rs = New ADODB.Recordset
' Open the connection and execute.
conn.Open sConnString
'MODIFIED: altered the SQL statement to use the search string with IN
Set rs = conn.Execute("SELECT customer FROM job_tab where jobnum2 IN " & newrow & "';")
' Check we have data.
If Not rs.EOF Then
' Transfer result.
Sheets(1).Range("B1").CopyFromRecordset rs
' Close the recordset
rs.Close
Else
MsgBox "Error: No records returned.", vbCritical
End If
' Clean up
If CBool(conn.State And adStateOpen) Then conn.Close
Set conn = Nothing
Set rs = Nothing
End Sub