I've a below VBA code and I want to read four values a, b, c, d from an excel column (A1:A4) so those can be part of my SQL query IN statement when I connect to database.
I build up the sWHEREclause to create ('a','b','c','d') string that but the final SQL query SQLStr seems to have some error and my code fails.
Can someone please help.
Thank you so much in advance.
Sub ADOExcelSQLServer()
Dim Cn As ADODB.Connection 'connection variable
Dim Server_Name As String ' text type
Dim Database_Name As String
Dim User_ID As String
Dim Password As String
Dim SQLStr As String
Dim rs As ADODB.Recordset ' Database connection variable
Dim rRange As Range
Dim rCell As Range
Dim sWHEREclause As String
Set rs = New ADODB.Recordset
Server_Name = "server name"
Database_Name = "Database name"
Set rRange = Sheet1.Range("A1:A4")
For Each rCell In rRange
sWHEREclause = sWHEREclause & "'" & rCell & "',"
Next rCell
'SQLStr = "Select * from MASTER_QUERY mq where mq.ModelNum in ('a','b','c','d')" 'commented line
SQLStr = "Select * from MASTER_QUERY mq where mq.ModelNum IN (" & sWHEREclause & ")"
Set Cn = New ADODB.Connection 'set connection with databse
Cn.Open "Provider=SQLOLEDB;Data Source=" & Server_Name & "; Initial Catalog=" & Database_Name & "; Integrated Security=SSPI;" 'connection parameter to the database
rs.Open SQLStr, Cn, adOpenStatic
' Dump to spreadsheet
With Worksheets("sheet1").Range("b2:z500") ' Enter your sheet name and range here
' Range(A1).Value = "ID)"
.ClearContents ' clear content first in excel
.CopyFromRecordset rs
End With
' Tidy up
rs.Close
Set rs = Nothing
Cn.Close
Set Cn = Nothing
End Sub
Your string ends with a ,
do your loop like this:
Dim delim as string
delim = ""
For Each rCell In rRange
sWHEREclause = sWHEREclause & delim & "'" & rCell & "'"
delim = ", "
Next rCell
After so many hours in that field, I could be able to get data from all the worksheets in closed workbook and could get data from specific columns using ADODB.
#Siddharth Rout helped me to be able to get the sheet names in the order of tab.
The following code works fine for only one closed workbook. But in fact I am trying to do the same and get all the data from the specific column (Reference - Ref No - Number ..) from several workbooks
Sub ImportFromClosedWorkbook()
Dim e, ws As Worksheet, cn As ADODB.Connection, rs As ADODB.Recordset, rsHeaders As ADODB.Recordset, b As Boolean, sFile As String, shName As String, strSQL As String, iCol As Long
sFile = ThisWorkbook.Path & "\Sample.xlsx"
Dim con As Object
Set con = CreateObject("DAO.DBEngine.120")
Dim rsData As ADODB.Recordset
Set cn = New ADODB.Connection
cn.Open ConnectionString:="Provider=Microsoft.ACE.OLEDB.12.0;Data Source='" & sFile & "';" & "Extended Properties=""Excel 12.0;HDR=YES;IMEX=1;"";"
Set ws = ThisWorkbook.ActiveSheet
Dim db As Object, i As Long
Set db = con.OpenDatabase(sFile, False, True, "Excel 12.0 XMl;")
For i = 0 To db.TableDefs.Count - 1
sName = db.TableDefs(i).Name
b = False
strSQL = "SELECT * FROM [" & sName & "]"
Set rsHeaders = New ADODB.Recordset
rsHeaders.Open Source:=strSQL, ActiveConnection:=cn, Options:=1
For iCol = 0 To rsHeaders.Fields.Count - 1
For Each e In Array("Ref No", "Reference", "Number")
If e = rsHeaders.Fields(iCol).Name Then
b = True: Exit For
End If
Next e
If b Then Exit For
Next iCol
If b Then
strSQL = "SELECT [" & e & "] FROM [" & sName & "]"
Set rsData = New ADODB.Recordset
Set rsData = cn.Execute(strSQL)
ws.Range("A" & ws.Cells(Rows.Count, 1).End(xlUp).Row + 1).CopyFromRecordset rsData
rsData.Close
End If
Next i
db.Close: Set db = Nothing
Set con = Nothing
cn.Close: Set cn = Nothing
End Sub
Is it suitable to build a public procedure or what's the best approach in that case and how can I release the objects in correct way?
I would break out your code even more - there are distinct activities which could be factored out into reusable methods.
FYI your tableDefs objects already contains the field names, so there's no need to separately query for those.
Eg:
Sub ImportFromClosedWorkbook()
Dim sFile As String, sheetName As String, colName As String, rs As ADODB.Recordset
Dim cols As Collection, col
sFile = ThisWorkbook.FullName
Set cols = FindColumns(sFile, Array("Ref", "Reference", "RefNo"))
'loop found columns
For Each col In cols
sheetName = col(0)
colName = col(1)
Debug.Print "##", sheetName, colName
Set rs = WorkBookQuery(sFile, "Select [" & colName & "] from [" & sheetName & "]")
If Not rs.EOF Then
' ActiveSheet.Cells(Rows.Count, "A").End(xlUp).CopyFromRecordset rs
End If
Next col
End Sub
'given a workbook path, find all column headings matching andname in arrNames
'returns a collections of [sheetName, columnName] arrays
Function FindColumns(wbFullPath As String, arrNames) As Collection
Dim tabledefs As Object, td As Object, f As Object, rv As New Collection
Set tabledefs = CreateObject("DAO.DBEngine.120") _
.OpenDatabase(wbFullPath, False, True, "Excel 12.0 XMl;").tabledefs
For Each td In tabledefs
For Each f In td.Fields
'Debug.Print td.Name, f.Name
If Not IsError(Application.Match(f.Name, arrNames, 0)) Then
rv.Add Array(td.Name, f.Name)
End If
Next f
Next td
Set FindColumns = rv
End Function
'run a SQL query against a workbook
Function WorkBookQuery(wbFullPath As String, SQL As String) As ADODB.Recordset
Dim rs As ADODB.Recordset
With New ADODB.Connection
.Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source='" & wbFullPath & "';" & _
"Extended Properties=""Excel 12.0;HDR=YES;IMEX=1;"";"
Set WorkBookQuery = .Execute(SQL, Options:=1)
End With
End Function
There seems to be a logical error in the process of cycling through the fields. It would be nice to use a user-defined function that checks if the field name exists.
Sub ImportFromClosedWorkbook()
Dim e, ws As Worksheet, cn As ADODB.Connection, rs As ADODB.Recordset, rsHeaders As ADODB.Recordset, b As Boolean, sFile As String, shName As String, strSQL As String, iCol As Long
Dim sField As String
sFile = ThisWorkbook.Path & "\Sample.xlsx"
Dim con As Object
Set con = CreateObject("DAO.DBEngine.120")
Dim rsData As ADODB.Recordset
Set cn = New ADODB.Connection
cn.Open ConnectionString:="Provider=Microsoft.ACE.OLEDB.12.0;Data Source='" & sFile & "';" & "Extended Properties=""Excel 12.0;HDR=YES;IMEX=1;"";"
Set ws = ThisWorkbook.ActiveSheet
Dim db As Object, i As Long
Set db = con.OpenDatabase(sFile, False, True, "Excel 12.0 XMl;")
For i = 0 To db.TableDefs.Count - 1
sName = db.TableDefs(i).Name
b = False
strSQL = "SELECT * FROM [" & sName & "]"
Set rsHeaders = New ADODB.Recordset
rsHeaders.Open Source:=strSQL, ActiveConnection:=cn, Options:=1
For iCol = 0 To rsHeaders.Fields.Count - 1
' For Each e In Array("Ref No", "Reference", "Number")
' If e = rsHeaders.Fields(iCol).Name Then
' b = True: Exit For
' End If
' Next e
' If b Then Exit For
' Next iCol
' If b Then
sField = rsHeaders.Fields(iCol).Name
If isField(sField) Then
strSQL = "SELECT [" & sField & "] FROM [" & sName & "]"
Set rsData = New ADODB.Recordset
Set rsData = cn.Execute(strSQL)
ws.Range("A" & ws.Cells(Rows.Count, 1).End(xlUp).Row + 1).CopyFromRecordset rsData
rsData.Close
End If
Next iCol
Next i
db.Close: Set db = Nothing
Set con = Nothing
cn.Close: Set cn = Nothing
End Sub
Function isField(sField As String) As Boolean
Dim vName As Variant, e As Variant
vName = Array("Ref No", "Reference", "Number")
For Each e In vName
If e = sField Then
isField = True
Exit Function
End If
Next e
End Function
If all the files have the same structure and are in a folder, you could use the FileSystemObject reference as below:
"https://stackoverflow.com/questions/10380312/loop-through-files-in-a-folder-using-vba"
and you could run the existing code in a loop in the file system code, hope that works
I'm trying to get data from an excel workbook which is updated every month and the name of the file changes according to the date - I have an instructions page using the today function which gives me the month (this are the cell I'm referencing in "Month")
Problem is, the file I'm opening is very very big, and so this takes over 5 minutes just to start excel and copy the data. Is there anyway to modify my code to get the data without opening the excel file?
This is my code so far -
Sub UploadData()
Dim Model As Workbook
Dim Q As Workbook
Dim rngFX As Range
Dim Month As String
Set Model = ActiveWorkbook
Set Q = Workbooks.Open(Filename:=Sheets("Instructions").Range("$C$29").Value)
Month = ("C" & (Model.Sheets("Instructions").Range("$C$23")))
With Q
With .Sheets(Month & " Summary")
Set rngFX = .Range("A61:R66")
rngFX.Copy Destination:=Model.Sheets("FOREX Forecast").Range("A3")
End With
End With
Q.Close savechanges:=False
With Model.Sheets("FOREX Forecast").UsedRange
.Value = .Value
End With
End Sub
Edit: I've added a picture of the error I'm getting - When I press debug it highlights this line:
Rs.Open strSQL, strConn
Try
Sub UploadData()
Dim Model As Workbook
Dim Q As Workbook
Dim rngFX As Range
Dim Year As String
Dim Fn As String, wsName As String
Dim strConn As String
Dim strSQL As String
Dim Ws As Worksheet
Dim Rs As Object
Set Model = ActiveWorkbook
Set Ws = Model.Sheets("FOREX Forecast")
Fn = Sheets("Instructions").Range("$C$29").Value
'Set Q = Workbooks.Open(Filename:=Sheets("Instructions").Range("$C$29").Value)
Month = "C" & Model.Sheets("Instructions").Range("$C$23")
wsName = "[" & Month & " Summary" & "$" & "A61:R66 ]"
strConn = "Provider=Microsoft.ACE.OLEDB.12.0;" & _
"Data Source=" & Fn & _
";Extended Properties=""Excel 12.0 Xml;HDR=NO;IMEX=1"";"
Set Rs = CreateObject("ADODB.Recordset")
strSQL = "select * from " & wsName
Rs.Open strSQL, strConn
Ws.Range("a3").CopyFromRecordset Rs
Rs.Close
Set Rs = Nothing
End Sub
I am getting "No value given for one or more required parameters", I am new in Excel VBA, Please suggest what is wrong with the query, Below is the code I am using to get the value from a access data based and I want to have the table name and the table column name on runtime.
Dim con As ADODB.Connection
Dim rs As New ADODB.Recordset
Dim name As String
Dim count As Integer
Dim FindString As String
Dim FindString1 As String
Dim SQLQuery As String
FindString = InputBox("Enter the table name")
FindString1 = InputBox("Enter search value")
count = 4
Dim strConn As String
Set con = New ADODB.Connectioncon.Mode = adModeReadWrite
If con.State = adStateClosed Then
strConn = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & "databasepath\Database3.accdb;Persist Security Info=False;"
con.ConnectionString = strConn
con.Open
Set rs.ActiveConnection = con
End If
SQLQuery = "select * from " & FindString & " where " & FindString & ".[LOGO] ='" & FindString1 & "'"
rs.Open SQLQuery
Looks like a problem with this SQL query.
"select * from " & FindString & " where [Resolution] = '" & FindString1 & "'"
I would suggest to make an extra step like this.
Dim SQLQuery as String
SQLQuery = "select * from [" & FindString & "] where [Resolution] = '" & FindString1 & "'"
rs.Open SQLQuery
Maybe you can have a look at this solution too.
No value given for one or more required parameters visual basic error
How to execute a query in MS Access db from Excel VBA code or macro.
MS-Access query accepts some parameters, that needs to be passed from Excel.
Thanks
Here is one possibility:
Dim cn As Object
Dim strFile As String
Dim strCon As String
Dim strSQL As String
strFile = "C:\docs\Test.mdb"
strCon = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & strFile
''Late binding, so no reference is needed
Set cn = CreateObject("ADODB.Connection")
cn.Open strCon
strSQL = "INSERT INTO ATable (AField) " _
& "VALUES (" & Sheet1.[A1] & ")"
cn.Execute strSQL
cn.Close
Set cn = Nothing
You can also refer in-line in the sql to a dataset from Excel.
EDIT re comments
Using a command:
strSQL = "SELECT * FROM ATable " _
& "WHERE AField = #AField"
With cmd
Set .ActiveConnection = cn
.CommandText = strSQL
.CommandType = 1 'adCmdText
''ADO Datatypes are often very particular
''adSmallInt = 2 ; adParamInput = 1
.Parameters.Append .CreateParameter("#AField", 2, 1, , Sheet1.[A1])
End With
Set rs = cmd.Execute
See also: http://support.microsoft.com/kb/181782
This uses ADODB.
Set m_Connection = New Connection
If Application.Version = "12.0" Then
m_Connection.Provider = "Microsoft.ACE.OLEDB.12.0"
Else
m_Connection.Provider = "Microsoft.Jet.OLEDB.4.0"
End If
m_Connection.Open <full path to Access DB>
If m_Connection.State > 0 Then
Dim rsSource As New Recordset
rsSource.Open strQuery, m_Connection, adOpenForwardOnly, adLockReadOnly
Dim result As Long
Dim rngTarget As Range
rngTarget = ThisWorkbook.Worksheets(m_SheetName).Range("A1")
If Not rsSource.BOF Then
result = rngTarget.CopyFromRecordset(rsSource)
End If
If rsSource.State Then rsSource.Close
Set rsSource = Nothing
End If
So it runs the query and puts it where you like. strQuery is the name of a query in the db or an SQL string.