Example:
I have the excel file test.xls and in it the sheet1, sheet2, sheet3, sheet4 with some information in it.
I want to export the result of 4 queries to those sheets, but I want to add the result after the last row with data and not to overwrite it.
I worked on something similar recently. In Excel I used VBA.
Dim cn As Object
Dim rs As Object
Dim strFile As String
Dim strCon As String
Dim strSQL As String
Dim s As String
Dim i As Integer, j As Integer
Dim StartDate As Date, EndDate As Date, ModStartDate As Date, ModEndDate As Date
'Modify the Start date because Maint 24hr cycle is 930 - 930 not 12 - 12
ModStartDate = StartDate - 1
''Access database
strFile = "S:\IT\Databases\Main_BE.mdb"
''This is the Jet 4 connection string, you can get more
''here : http://www.connectionstrings.com/excel
strCon = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & strFile & ";"
''Late binding, so no reference is needed
Set cn = CreateObject("ADODB.Connection")
Set rs = CreateObject("ADODB.Recordset")
cn.Open strCon
'Get the info from Access
strSQL = "SELECT * FROM Work_Orders " _
& "WHERE Repair_Start_Date >= #" & ModStartDate & "# " _
& "AND Repair_Start_Date <= #" & EndDate & "# " _
& "ORDER BY Repair_Start_Date, Repair_Start_Time"
rs.Open strSQL, cn
'Paste the SQL query at A10 Sheet3
Sheet3.Cells(10, 1).CopyFromRecordset rs
''Tidy up
rs.Close
Set rs = Nothing
cn.Close
Set cn = Nothing
You would just need to modify the SQL statement, and then to add a new row you could use a variable to count the number of existing rows with:
"=Counta(some range:some range)"
Then just add 1 to the variable for the next row.
Thanks everybody!
I could solve it using :
Private Sub Command0_Click()
Dim rstName As Recordset
Set rstName = CurrentDb.OpenRecordset("query1")
Dim objApp As Object, objMyWorkbook As Object, objMySheet As Object, objMyRange As Object
Set objApp = CreateObject("Excel.Application")
Set objMyWorkbook = objApp.Workbooks.Open("c:/exportarexcell/teste.xls")
Set objMySheet = objMyWorkbook.Worksheets("FolhaTeste")
Set objMyRange = objMySheet.Cells(objApp.ActiveSheet.UsedRange.Rows.Count + 1, 1)
With objMyRange
rstName.MoveFirst 'Rewind to the first record
.Clear
.CopyFromRecordset rstName
End With
End Sub
Related
I have a list of account ID in column A. The range of that column is dynamic. How do I write a module that will take those values and use them in an SQL IN statement. Below is my attempt at doing this. I pieced together multiple scripts I found so sorry if it is a mess.
Sub ConnectSqlServer()
Dim conn As ADODB.Connection
Dim rs As ADODB.Recordset
Dim sConnString As String
Dim wbBook As Workbook
Dim wsSheet As Worksheet
Dim lastrow As Long
Dim sl As Long
With wsSheet
lastrow = .Range("A" & .Rows.Count).End(xlUp).Row
End With
' Appending the values to a single variable
For i = 1 To lastrow
s1 = s1 & "'" & Val(wsSheet.Cells(i, 1)) & "'" & ","
Next
' Variable which could be used in IN command
If lastrow > 0 Then
s1 = Mid(s1, 1, Len(s1) - 1)
s1 = "(" & s1 & ")"
Else
Exit Sub
End If
' ' Create the connection string.
sConnString = "Driver={ODBC Driver 13 for SQL Server}; Server=snapshot;" & _
"Database=salesforce_replica;" & _
"Trusted_Connection=yes;"
' 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 * FROM dbo.account where Account_ID_18__c = " & s1;)
' Check we have data.
If Not rs.EOF Then
' Transfer result.
Sheets(1).Range("A1").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
My goal is to figure out how to take a dynamic range of values and use them within an SQL Where statement.
Try something like this:
Sub ConnectSqlServer()
Dim conn As ADODB.Connection, rs As ADODB.Recordset
Dim sConnString As String
Dim wb As Workbook, ws As Worksheet, rngIds As Range, sql As String, inList As String
Set wb = ThisWorkbook
Set ws = wb.Sheets("list")
Set rngIds = ws.Range("A1:A" & ws.Cells(Rows.Count, "A").End(xlUp).Row)
inList = InClause(rngIds)
If Len(inList) = 0 Then
MsgBox "No id values!"
Exit Sub 'nothing to query...
End If
sConnString = "Driver={ODBC Driver 13 for SQL Server}; Server=snapshot;" & _
"Database=salesforce_replica;" & _
"Trusted_Connection=yes;"
Set conn = New ADODB.Connection
conn.Open sConnString
Set rs = conn.Execute("SELECT * FROM dbo.account where Account_ID_18__c in " & inList)
If Not rs.EOF Then
wb.Sheets(1).Range("A1").CopyFromRecordset rs
Else
MsgBox "Error: No records returned.", vbCritical
End If
rs.Close
conn.Close
End Sub
'Generate a SQL "in" list from distinct values in range `rng`
' Add single quotes around values unless `IsNumeric` is True
' Note if `rng` has too many values you may exceed your max. SQL query size!
Function InClause(rng As Range, Optional IsNumeric As Boolean = False) As String
Dim c As Range, dict As Object, arr, qt As String, v
Set dict = CreateObject("scripting.dictionary")
For Each c In rng.Cells
v = Trim(c.Value)
If Len(v) > 0 Then dict(v) = 1
Next c
If Not IsNumeric Then qt = "'"
If dict.Count > 0 Then
InClause = "(" & qt & Join(dict.keys, qt & "," & qt) & qt & ")"
End If
End Function
'Below is the current code that I have and it will export to the excel workbook and worksheet correctly. The only problem is that I need to limit the data that gets exported by a month end date range (example: 1/31/2017 to 4/30/2017) and also by a plant number (example: "4101") thanks for any help it is greatly appreciated.
Public Function InventoryXport_4100()
Dim appXL As Object
Dim wb As Object
Dim wks As Object
Dim xlf As String
Dim rs As DAO.Recordset
Dim fld As Field
Dim intColCount As Integer
xlf = "Z:\COST ACCOUNTING INFO\Inventory Reports\MyFile.xlsx"
Set rs = CurrentDb.OpenRecordset("(QS)_Inventory")
Set appXL = CreateObject("Excel.Application")
Set wb = appXL.Workbooks.Open(xlf)
Set wks = wb.Sheets("Inventory Xport") 'Sheet name
If rs.EOF = True Then
MsgBox "No data", vbOKOnly
Exit Function
End If
With appXL
.Application.worksheets("Inventory Xport").SELECT
.Application.columns("A:AQ").SELECT
.Application.columns.Clear
End With
intColCount = 1
For Each fld In rs.Fields
wks.Cells(1, intColCount).Value = fld.Name
intColCount = intColCount + 1
Next fld
appXL.displayalerts = False
wks.Range("A2").CopyFromRecordset rs
appXL.Visible = True
With appXL
.Application.worksheets("Inventory Xport").SELECT
.Application.columns("A:AQ").SELECT
.Application.columns.AutoFit
.Application.Range("A2").SELECT
.Application.ActiveWindow.FreezePanes = True
End With
wb.Save
wb.Close
appXL.Quit
Set wb = Nothing
rs.Close
Set rs = Nothing
End Function
You can use:
Dim Date1 As Date
Dim Date2 As Date
Dim PlantNr As String
Dim Sql As String
Date1 = #1/31/2017#
Date2 = #4/30/2017#
PlantNr = "4101"
Sql = "Select * From [(QS)_Inventory] Where YourDateField Between #" & Format(Date1, "yyyy\/mm\/dd") & "# And #" & Format(Date2, "yyyy\/mm\/dd") & "# And [Plant Number] = '" & PlantNr & "'"
Set rs = CurrentDb.OpenRecordset(Sql)
I created a query separately and now want to use VBA to read its records and then send certain fields of all rows in an email.
I am currently stuck on trying to extract all the rows from the recordset. I know how to do it for one record, but not with a dynamic recordset. Every week, the recordset could potentially have 1-10 (approx.) records. I had hoped to do this by dynamically reading all rows, saving the fields that I want into variables, and then adding that to the email body, but I arrived at an error.
I'm getting an error that says: Run-time error '3265': Item not found in this collection.
Does anyone know how to fix this error and how I can put all resulting rows of the recordset into the email body?
The code:
Private Sub Form_Timer()
'current_date variable instantiated in a module elsewhere
current_date = Date
'Using the Date function to run every Monday, regardless of the time of day
If current_date = (Date - (DatePart("w", Date, 2, 1) - 1)) Then
'MsgBox ("the current_date variable holds: " & current_date)
Dim dbs As DAO.Database
Dim rst As DAO.Recordset
Dim qdf As DAO.QueryDef
Dim prm As DAO.Parameter
Dim varRecords As Variant
Dim intNumReturned As Integer
Dim intNumColumns As Integer
Dim intColumn As Integer
Dim intRow As Integer
Dim strSQL As String
Dim rst_jobnumber As String
Dim rst_bfloc As String
Set dbs = CurrentDb
Set qdf = dbs.QueryDefs("qry_BMBFLoc")
Set rst = qdf.OpenRecordset
If rst.EOF Then
MsgBox "Null."
Else
'Found this part of the code online and not sure if I'm using it right.
varRecords = rst!GetRows(3)
intNumReturned = UBound(varRecords, 2) + 1
intNumColumns = UBound(varRecords, 1) + 1
For intRow = 0 To intNumReturned - 1
For intColumn = 0 To intNumColumns - 1
Debug.Print varRecords(intColumn, intRow)
Next intColumn
Next intRow
'End of code found online.
'rst.MoveFirst 'commenting this out because this query could potentially return multiple rows
rst_jobnumber = rst!job & "-" & rst!suffix
rst_bfloc = rst!Uf_BackflushLoc
rst.Close
dbs.Close
Set rst = Nothing
Set dbs = Nothing
'Dim oApp As Outlook.Application
'Dim oMail As MailItem
'Set oApp = CreateObject("Outlook.application")
'mail_body = "The following jobs do not have the special BF location set in Job Orders: " & rst_
'Set oMail = oApp.CreateItem(olMailItem)
'oMail.Body = mail_body
'oMail.Subject = "Blow Molding Jobs Missing BF Location"
'oMail.To = "something#something.com" 'in the future, create a function that finds all of the SC users' emails from their Windows user
'oMail.Send
'Set oMail = Nothing
'Set oApp = Nothing
End If
End If
ErrorHandler:
MsgBox "Error #: " & Err.Number & vbCrLf & vbCrLf & Err.Description
End Sub
Try working with this code and see how it works for you. I was unsure if you were sending one email per or one email listing all (I assumed the latter)
Dim dbs As DAO.Database
Dim rst As DAO.Recordset
Dim strMessageBody As String
Set dbs = CurrentDb
Set rst = CurrentDb.OpenRecordset("qry_BMBFLoc")
strMessageBody = "The following jobs do not have the special BF location set in Job Orders: "
If Not (rst.EOF And rst.BOF) Then
rst.MoveFirst
Do Until rst.EOF = True
strMessageBody = strMessageBody & rst!job & "-" & rst!suffix & ","
rst.MoveNext
Loop
If Right(strMessageBody, 1) = "," Then strMessageBody = Left(strMessageBody, Len(strMessageBody)-1)
End If
rst.Close
Set rst = Nothing
Set dbs = Nothing
EDIT - not using dot operator
Replace
varRecords = rst!GetRows(3)
with
varRecords = rst.GetRows(3)
Do you have three rows in your recordset?
If not rst!GetRows(3) will return false - and then next line will fail when you try to use UBound.
A good example of how to implement GetRows
Another possibility is if you're trying to access a Field that's not in your recordset on a line that has rst!
I'm trying to open a record set using a SQL string. I get run time error 3061 "Too Few Parameters." any help would be appreciated.
Dim stAppName As String
Dim stURL As String
Dim rst As Recordset
Dim dbs As Database
Dim stringToSearch As Integer
Dim strSQL As String
Set dbs = CurrentDb
stringToSearch = InputBox("What is your route #?", "Enter route #: ")
strSQL = "SELECT ESRP.* FROM ESRP WHERE ESRP.Route=stringToSearch"
Set rst = dbs.OpenRecordset(strSQL)
Please change the code line of strSQL as follows, as suggested by Fionnuala you need to use variable outside the quotes.
Assuming Route field is Text data type, we need to put single quote for strings, if its number no single quote, for dates put # instead of single quote
strSQL = "SELECT ESRP.* FROM ESRP WHERE ESRP.Route='" & stringToSearch & "'"
It's a little sample, maybe it can help you
Public Function fn_SQL_dbOpenRecordset(Optional vsql As String = "") As Recordset
Dim dbs As DAO.Database
Dim rs As Recordset
On Error GoTo END_CODE
'Set the database
Set dbs = CurrentDb
Set rs = dbs.OpenRecordset(vsql, dbOpenForwardOnly) 'you can use: dbOpenDynamic; dbOpenSnapshot; dbOpenTable
Set fn_SQL_dbOpenRecordset = rs
Exit Function
END_CODE:
Set fn_SQL_dbOpenRecordset = Nothing
End Function
Public Sub Program_Test()
On Error GoTo ERROR_SUB
Dim rs As Recordset
Dim sName As String
sName = "Joe"
sName = "'" & sName & "'" 'WARNING: BE CAREFUL WITH SQL INJECTION !!! Google it
Set rs = fn_SQL_dbOpenRecordset("select * from table1 d where PersonName = " & sName)
Dim i As Long
i = 0
While Not rs.EOF
Debug.Print rs(0).Value & " - " & rs(1).Value
rs.MoveNext
Wend
ERROR_SUB:
On Error Resume Next
If Not rs Is Nothing Then rs.Close
Set rs = Nothing
End Sub
i want to create a custom excel function which takes the cell value as a parameter to query the mysql database
Function excelmysql2()
Dim odjDB As ADODB.Connection
Dim sqlstr As String
Dim rs As ADODB.Recordset
Dim oRS, nRec, oFld
Dim Row
'----------------------------------------------------------------------
Set odjDB = New ADODB.Connection
Sheets("Sheet1").Select
odjDB.Open "DRIVER={MySQL ODBC 5.3 Unicode Driver};" & _
"SERVER=192.168.0.64;" & _
"DATABASE=mifos;" & _
"Port=3307;" & _
"USER=root;" & _
"PASSWORD=admin;"
Set oRS = odjDB.Execute("SELECT account.customer_id FROM mifos.account WHERE (mifos.account.account_id= '" & Range("A3").Value & "')")
nRec = 0
Row = 3
Do While Not oRS.EOF
For Each oFld In oRS.Fields
Worksheets("Sheet1").Cells(Row, 3).Value = oRS("customer_id")
Row = Row + 1
On Error Resume Next
oRS.MoveNext
Next
Loop
oRS.Close
odjDB.Close
End Function
as you noticed in have the cell number set in the function
because i couldn't find a way to have it dynamic.
i want to be able to use the function like any excel function where i can pass the value of a cell and get the queried value from mysql
what should i put instead of the Range("A3") to be able to use this function in excel by passing cell values?
(EX: =excelmysql2(A1)...)
thanks
the below eg. relates to your question
Use it and just change the parameters....
It illustrates a query that returns a (closing rate "MEND") FX rate based in the month and year from a Table called rates in the database called finance
SELECT rates.MEND
FROM rates
WHERE rates.Cur = 'USD'
AND rates.Month = JAN
AND rates.Year = 2015
returns 14.35
Table : rates
Cur | Month| Year | MEND
ZAR | JAN | 2015 | 1.453
USD | JAN | 2015 | 14.35
Function MySQL_Month_endRate(Curr As String, Monn As Integer, yearr As Integer) As String
'##################
'## Connection ##
'##################
Dim conn As Variant
Dim rs As Variant
Dim cs As String
Dim query As String
Dim Table_Name As String
Table_Name = "rates"
Dim Database_Name As String
Database_Name = "finance"
Set conn = CreateObject("adodb.connection")
Set rs = CreateObject("adodb.recordset")
cs = "DRIVER={MySQL ODBC 5.3 ANSI Driver};"
cs = cs & "DATABASE=" & Database_Name & ";"
cs = cs & "SERVER=127.0.0.1"
conn.Open cs, "root", "root" 'UserName and Password else WindowsNT Autentication
'####################
'## QUERY ##
'####################
query = "SELECT rates.MEND FROM rates WHERE rates.Cur = '" & Curr & "' AND rates.Month = " & Monn & " AND rates.Year = " & yearr
'Curr As String, Monn As Integer, yearr As
Debug.Print query
rs.Open query, conn
'####################
'## RECORD SET ##
'####################
Do Until rs.EOF
' row = row + 1
' Cells(row, 5).Value = rs.Fields("Serial key").Value
Debug.Print rs.Fields("MEND").Value
MySQL_Month_endRate = rs.Fields("MEND").Value
rs.MoveNext
Loop
'#####################
'## Return ##
'#####################
Set rs = Nothing
conn.Close
Set conn = Nothing
'myRibbon.Invalidate
'End
errline:
If Err.Description <> "" Then MsgBox Err.Description
'MsgBox Err.Description
End Function