I have a couple (3) SELECT queries which are linked to excel files and require regular updates (weekly).
I am trying to create a module in access using VBA that can do two things:
Update a few parameters to be selected, which I defined as variables that I can update manually: CurrentWeek, RetailWeek, CurrentYear and Current Date
After the update it would run the queries so I can refresh the data in the excel file.
I have tried a couple things but so far no success, I think the closest I got is:
Private Sub DevicePerformanceDashboard()
Dim CurrentWeek, RetailWeek, CurrentYear As Long
Dim CurrentDate As Date
Dim qRP, qPP, qMV As DAO.QueryDef
Dim dbs As DAO.Database
Set dbs = CurrentDb()
CurrentYear = 2018
CurrentWeek = 31
RetailWeek = CurrentWeek - 8
CurrentDate = TimeValue("2018-06-01 00:00:00")
Set qRP = CurrentDb.QueryDefs("DPDashboardRetail")
Set qPP = CurrentDb.QueryDefs("DPDashboardPricePrediction")
Set qMV = CurrentDb.QueryDefs("DPDashboardVolume")
qRP.Parameters("YearNb").Value = CurrentYear
qRP.Parameters("WeekNb").Value = ">" & RetailWeek
qPP.Parameters("WeekNb").Value = ">" & CurrentWeek
qPP.Parameters("PreWeekNb").Value = CurrentWeek
qPP.Parameters("PreYearNb").Value = CurrentYear
qMV.Parameters("VolumeAndValueDate").Value = CurrentDate
DoCmd.OpenQuery "DPDashboardRetail"
DoCmd.OpenQuery "DPDashboardPricePrediction"
DoCmd.OpenQuery "DPDashboardVolume"
End Sub
Currently I get an error saying Object required but I tried it some other ways and I got different errors at different times.
UPDATE: Now the error is at the line:
qRP.Parameters("YearNb").Value = CurrentYear
Item not found in this collection
Any idea on what I am doing wrong?
Many errors:
Dim CurrentWeek As Long
Dim RetailWeek As Long
Dim CurrentYear As Long
Dim CurrentDate As Date
Dim qRP As DAO.QueryDef
Dim qPP As DAO.QueryDef
Dim qMV As DAO.QueryDef
Dim dbs As DAO.Database
Set dbs = CurrentDb
CurrentYear = 2018
CurrentWeek = 31
RetailWeek = CurrentWeek - 8
CurrentDate = DateSerial(2018, 6, 1)
Set qRP = CurrentDb.QueryDefs("DPDashboardRetail")
Set qPP = CurrentDb.QueryDefs("DPDashboardPricePrediction")
Set qMV = CurrentDb.QueryDefs("DPDashboardVolume")
qRP.Parameters("YearNb").Value = CurrentYear
' Cannot do:
' qRP.Parameters("WeekNb").Value = ">" & RetailWeek
' Cannot do:
' qPP.Parameters("WeekNb").Value = ">" & CurrentWeek
qPP.Parameters("PreWeekNb").Value = CurrentWeek
qPP.Parameters("PreYearNb").Value = CurrentYear
qMV.Parameters("VolumeAndValueDate").Value = CurrentDate
qRP.Execute
qPP.Execute
qMV.Execute
Item not found in this collection
This indicates a missing or misspelled field/parameter in the SQL.
Set is a keyword that only should be used with objects, hence the Object required error. To assign values to a variable, just VariableName = SomeValue is enough, only use Set variableName = SomeObject when assigning objects.
Furthermore, qdf.Parameters goes with qdf.Execute to execute the query. DoCmd.OpenQuery goes with DoCmd.SetParameter to set parameters.
The parameters collection created by DoCmd.SetParameter gets cleared when you use DoCmd.OpenQuery, so that requires some restructuring of your code.
Option Compare Database
Option Explicit
Private Sub DevicePerformanceDashboard()
Dim CurrentWeek, RetailWeek, CurrentYear As Long
Dim CurrentDate As Date
Dim dbs As DAO.Database
Set dbs = CurrentDb()
CurrentYear = 2018
CurrentWeek = 31
RetailWeek = CurrentWeek - 8
CurrentDate = TimeValue("2018-06-01 00:00:00")
DoCmd.SetParameter "YearNb", CurrentYear
DoCmd.SetParameter "WeekNb", ">" & RetailWeek
DoCmd.OpenQuery "DPDashboardRetail"
DoCmd.SetParameter "WeekNb", ">" & CurrentWeek
DoCmd.SetParameter "PreWeekNb", CurrentWeek
DoCmd.SetParameter "PreYearNb", CurrentYear
DoCmd.OpenQuery "DPDashboardPricePrediction"
DoCmd.SetParameter "VolumeAndValueDate", CurrentDate
DoCmd.OpenQuery "DPDashboardVolume"
End Sub
Related
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 running some code to split a slash-separated field into multiple rows, but the first value in the series is not carrying over. Does anyone know what I'm missing. Also, Rows that only have one record are not carrying over.
Public Sub ReformatTable()
Dim db As DAO.Database
Dim rs As DAO.Recordset
Dim rsADD As DAO.Recordset
Dim strSQL As String
Dim strMPG, strBusinessName, strCustomerNumber, strCustomerName, strCountStartDate, strCCStatus As String
Dim strSplitMPG As String
Dim varData As Variant
Dim i As Integer
Set db = CurrentDb
' Select all eligible fields (have a comma) and unprocessed (SPLIT_MPG is Null)
strSQL = "SELECT BUSINESS_NAME, CUSTOMER_NUMBER, CUSTOMER_NAME, COUNT_START_DATE, CC_STATUS, MPG, SPLIT_MPG FROM [tmStarCycleCountStatuses_SlashesforCommas] WHERE ([MPG] Like ""*/*"") AND ([SPLIT_MPG] Is Null)"
Set rsADD = db.OpenRecordset("tmStarCycleCountStatuses_SlashesforCommas", dbOpenDynaset, dbAppendOnly)
Set rs = db.OpenRecordset(strSQL, dbOpenDynaset)
With rs
While Not .EOF
strMPG = !MPG
strBusinessName = !BUSINESS_NAME
strCustomerNumber = !CUSTOMER_NUMBER
strCustomerName = !CUSTOMER_NAME
strCountStartDate = !COUNT_START_DATE
strCCStatus = !CC_STATUS
varData = Split(strMPG, "/") ' Get all comma delimited fields
' Update First Record
.Edit
!SPLIT_MPG = Trim(varData(0)) ' remove spaces before writing new fields
.Update
' Add records with same first field
' and new fields for remaining data at end of string
For i = 1 To UBound(varData)
With rsADD
.AddNew
!MPG = strMPG
!SPLIT_MPG = Trim(varData(i)) ' remove spaces before writing new fields
!BUSINESS_NAME = strBusinessName
!CUSTOMER_NUMBER = strCustomerNumber
!CUSTOMER_NAME = strCustomerName
!COUNT_START_DATE = strCountStartDate
!CC_STATUS = strCCStatus
.Update
End With
Next
.MoveNext
Wend
.Close
rsADD.Close
End With
Set rsADD = Nothing
Set rs = Nothing
db.Close
Set db = Nothing
End Sub
I can't post images yet due to reputation constrictions, but here are some links.
Here's the multiple after the code:
https://s9.postimg.org/fn3u70b5b/Multiple.jpg
Here's the single records after code run:
https://s10.postimg.org/bfq9z4snt/Singles.jpg
I feel like there's something super simple that I'm missing here, but it looks like I'm already taking the MPG over, so i'm curious as to why I'm not getting the singles or the first of the series. Any help would be appreciated! Thank you.
It looks right to me, except that you have to declare like this:
Dim strMPG As String
Dim strBusinessNames As String
Dim strCustomerNumbers As String
Dim strCustomerNames As String
Dim strCountStartDates As String
Dim strCCStatus As String
I guess you will have to insert some lines with Debug.Print .. to narrow down the happenings.
Got it. Ended up changing my approach. This code will work. The pattern, regardless of length, would always be the same, so I used a Right/Left combo and integers
Public Sub ReformatmStarCycleCountStatusesTable()
Dim db As DAO.Database
Dim rs As DAO.Recordset
Dim strSQL As String
Dim strMPG As String
Dim strBusinessName As String
Dim strCustomerNumber As String
Dim strCustomerName As String
Dim dteCountStartDate As Date
Dim strCCStatus As String
Dim strSplitMPG As String
Dim intRemainingLength As Integer
Dim intInitialLength As Integer
Dim intStartPoint As Integer
Dim varData As Variant
Set db = CurrentDb
DoCmd.SetWarnings False
' Select all eligible fields (have a comma)
strSQL = "SELECT * FROM [mStar Cycle Count Statuses] WHERE [PRODUCT_FILTER_VALUE] is not null"
Set rs = db.OpenRecordset(strSQL, dbOpenDynaset)
With rs
While Not .EOF
strMPG = !PRODUCT_FILTER_VALUE
strBusinessName = !BUSINESS_NAME
strCustomerNumber = !CUSTOMER_NUMBER
dteCountStartDate = !COUNT_START_DATE
strCCStatus = !Status
intInitialLength = Len(strMPG)
intRemainingLength = intInitialLength
intStartPoint = 2
Do While intRemainingLength > 0
strSQL = "INSERT INTO tmStarCycleCountStatuses VALUES ('" & strBusinessName & "', '" & strCustomerNumber _
& "', #" & dteCountStartDate & "#, '" & strCCStatus & "', '" & Right(Left(strMPG, intStartPoint), 2) & "')"
DoCmd.RunSQL (strSQL)
intStartPoint = intStartPoint + 3
intRemainingLength = intRemainingLength - 3
Loop
intStartPoint = 1
.MoveNext
Wend
.Close
End With
DoCmd.SetWarnings True
Set rs = Nothing
db.Close
Set db = Nothing
End Sub
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!
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
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