Depending on some inputs from the users in a user form, I am building code to automatically create calculated columns based on defined criteria. However, I am getting a syntax error in the field expression, code provided below.
Option Compare Database
Private Sub Calculate_Click()
Dim db As Database
Dim rs As Recordset
Dim x As Integer
Dim Months As Integer
Dim WPmonthly As String ' field name for monthly written premium
Dim runningDate As Date
Dim useDateLower As Date
Dim useDateUpper As Date
Dim tdf As dao.TableDef
Dim fld As dao.Field2
Months = Me.YearsBack * 12 + Month(Me.ValDate)
If Me.Period = "monthly" Then
Set db = CurrentDb
Set tdf = db.TableDefs("tblEPdata")
For x = 1 To Months
runningDate = Format(DateAdd("m", -x + 1, Me.ValDate), "mm yyyy")
useDateLower = runningDate
useDateUpper = Format(DateAdd("m", -x + 2, Me.ValDate), "mm yyyy")
WPmonthly = "WP M" & Month(runningDate) & " " & Year(runningDate)
Set fld = tdf.CreateField(UPRmonthly)
fld.Expression = "iif([issuedate]<#" & useDateUpper & "#,iif([issuedate]>=#" & useDateLower & "#,[grossPremium]))" ' output gross premium if issue date is between usedateupper and usedatelower, otherwise 0
tdf.Fields.Append fld
Next
MsgBox "added"
End If
End Sub
You don't have enough arguments for iif - it takes three arguments (see here):
IIf ( expr , truepart , falsepart )
Judging by your comment in the code, you want either:
"iif([issuedate]<#" & useDateUpper & "#,iif([issuedate]>=#" & useDateLower & "#,[grossPremium],0),0)"
Or you can simplify this e.g. to:
"iif([issuedate]<#" & useDateUpper & "# and [issuedate]>=#" & useDateLower & "#,[grossPremium],0)"
Figured it out. The variable wpmonthly was supposed to be used where uprmonthly was being used. uprmonthly was not defined.
Cheers
Related
I need a macro in VBA Access. I have a table with all dates of the years like columns (and also the dates are the names of the fields). I've made a form where the user selects two dates, and the macro would count all the data between these 2 columns.
For the example, I put two fixed dates. The problem is I need count between the 2 columns, and the columns can change depending the input of the user. The table is EVOLUTIVO_ASISTENCIA and the field can change depends the user selection. Ihe following code EVOLUTIVO_ASISTENCIA.[" & INICIO_MES_VAR1 & "] is the field "01-01-2023" of the EVOLUTIVO_ASISTENCIA table, but the syntax is wrong and does not function. Can anyone help me?
The code:
Private Sub BUSQUEDA()
Dim CONTEO As String
Dim VAR1 As String
Dim INICIO_MES_VAR1 As Date, TERMINOS_MES_VAR1 As Date
INICIO_MES_VAR1 = Format("01-01-2023", "dd-mm-yyyy")
TERMINOS_MES_VAR1 = Format("31-01-2023", "dd-mm-yyyy")
VAR1 = "VAR1"
CONTEO = "SELECT COUNT(*) FROM EVOLUTIVO_ASISTENCIA " & _
"WHERE EVOLUTIVO_ASISTENCIA.[NOMBRES]='" & VAR1 & "' " & _
** "BETWEEN EVOLUTIVO_ASISTENCIA.[" & INICIO_MES_VAR1 & "] AND EVOLUTIVO_ASISTENCIA.[" & TERMINOS_MES_VAR1 & "]"**
DoCmd.RunSQL CONTEO
End Sub
You don't run a select query, you open it as a recordset. So try:
Private Sub BUSQUEDA()
Dim Records As DAO.Recordset
Dim CONTEO As String
Dim VAR1 As String
Dim INICIO_MES_VAR1 As String
Dim TERMINOS_MES_VAR1 As String
Dim ASISTENCIA_CONTEO As Long
INICIO_MES_VAR1 = "01-01-2023"
TERMINOS_MES_VAR1 = "31-01-2023"
VAR1 = "VAR1"
CONTEO = "SELECT COUNT(*) FROM EVOLUTIVO_ASISTENCIA " & _
"WHERE EVOLUTIVO_ASISTENCIA.[NOMBRES]='" & VAR1 & "' " & _
"BETWEEN EVOLUTIVO_ASISTENCIA.[" & INICIO_MES_VAR1 & "] AND EVOLUTIVO_ASISTENCIA.[" & TERMINOS_MES_VAR1 & "]"
Set Records = CurrentDb.OpenRecordset(CONTEO)
' Read/list/print records.
' Retrieve the value of the first and only field of the first and only record.
ASISTENCIA_CONTEO = Records(0).Value
' Close when done.
Records.Close
End Sub
Hi I have been trying this for hours and it doesn't matter how much I search to try different options I cannot get the lookup for give a result that I am looking for. I am testing it using a date and work code that I know is in the table that I am referring to.
I am using the input box to provide the date and fixing the work code as 13 (Dispatch). The lookup should be returning the date in the table as the date input is in the table. My code is:
Sub Append_Dispatch()
Dim dbs As Object
Dim qdf As querydef
Dim InputDateString As String
Dim InputDate As Date
Dim RtnDate As String
Dim chkDate As Date
Dim WC As Long
Set dbs = CurrentDb
Set qdf = dbs.querydefs("Dispatch Append to Production Data")
WC = 13
InputDateString = InputBox("Please enter start date to import", "Date")
InputDate = DateValue(InputDateString)
RtnDate = DLookup("[Date of Action]", "Production Data", "[Date of Action]= #" & InputDate & "# AND [Work Code] = " & WC & "")
chkDate = DateValue(RtnDate)
If InputDate = chkDate Then
IB = MsgBox("This dispatch date has already been entered:" & vbCrLf & "Please check and use a date after " & Dte, vbOKOnly, "Date Error")
Exit Sub
End If
'qdf.Parameters("Dispatch Date").Value = InputDate
'qdf.Execute
'qdf.Close
'Set qdf = Nothing
'Set dbs = Nothing
End Sub
Also I cannot get the code to work after the end if to input the parameter and run the append query. But that is another issue.
Any ideas please.....
I'm trying to grab the last week of appointments using VBA in Outlook.
I'm using the .Restrict method, but something is making my string grab 3 years further back.
I start by declaring formatted dates for my time bracket:
myStart = Format(DateAdd("d", -7, Now()), "ddddd h:nn AMPM")
myEnd = Format(Now(), "ddddd h:nn AMPM")
I build a string to hold my restriction criterion.
strRestriction = "[Start] <= '" & myEnd _
& "' AND [End] >= '" & myStart & "'"
Finally I call restrict on my appointment items:
Set oRestrItems = oItems.Restrict(strRestriction)
For a little more context, here's how I use/call the result:
For Each oApptItem In oRestrItems 'oItems will grab everything, but that's hardly perfect.
If oApptItem.Sensitivity <> olPrivate Then
MsgBox (oApptItem.Subject)
MsgBox (oApptItem.Start)
MsgBox (oApptItem.End)
End If
Next
I can guess that you are missing two statements.
oItems.IncludeRecurrences = True
oItems.Sort "[Start]"
If this is the case, you can ask another question about why the Restrict requires these additional statements. Someone may have an answer.
Minimal, Complete, and Verifiable example. Try commenting out either or both statements. You should see that the items are not the same.
Option Explicit
Sub LastWeekAppts()
Dim objFolder As Folder
Dim oItems As items
Dim oRestrItems As items
Dim strRestriction As String
Dim myStart As Date
Dim myEnd As Date
Dim temp As Object
Set objFolder = Session.GetDefaultFolder(olFolderCalendar)
Set oItems = objFolder.items
' *****************************************
' Odd results without these two statements
oItems.IncludeRecurrences = True
oItems.Sort "[Start]"
' *****************************************
myEnd = Date
myStart = DateAdd("d", -7, Date)
Debug.Print " myStart: " & myStart
Debug.Print " myEnd : " & myEnd
strRestriction = "[Start] <= '" & myEnd _
& "' AND [End] >= '" & myStart & "'"
Debug.Print strRestriction
Set oRestrItems = oItems.Restrict(strRestriction)
For Each temp In oRestrItems
Debug.Print temp.start & " - " & temp.Subject
Next temp
End Sub
I updated the code in an excel add-in I created that is saved on my company's shared drive. I've added some of the add-ins macros under a custom tab on the Excel ribbon. Before updating the code, I already had it set as an Active Application Add-In, so I figured I could just update the code and the buttons would work just like they were before. However, when I click one of the custom ribbon buttons I get the error "Cannot run the macro "macro file path". The macro may not be available in this workbook or all macros may be disabled".
I've googled for solutions already and most involve changing Trust Center Settings-->Macro Settings to Enable all macros and checking the Trust Access to the VBA project object model button, which I had done before updating the add-in code.
I've also opened up the VBE and see the add-in file in the Project Explorer window right next to the workbook I'm trying to run the add-in macro from. Does anyone know why this is happening? It was working fine until I updated the add-in code.
Here is the original add-in code:
Function BuildBudgetSQL(PageFilters As Range, Table As Range)
Application.Volatile
'PageFilters As String, Year As Date, x_axis As String, y_axis As String)
Dim cell As Range
'Starts SQL statement
BuildBudgetSQL = "SELECT * FROM " & "[" & Table.Offset(0, 2).Value & "]" & " WHERE "
'Adds WHERE and AND clauses to SQL statement
For Each cell In PageFilters
BuildBudgetSQL = BuildBudgetSQL & "[" & cell.Value & "] " & cell.Offset(0, 1) & " '" & cell.Offset(0, 2).Value & "'" & " " & cell.Offset(1, -1).Value & " "
Next
'Chops off trailing " AND" and add ";" on end of SQL statement
BuildBudgetSQL = Mid(BuildBudgetSQL, 1, Len(BuildBudgetSQL) - 2) & ";"
End Function
Sub GetBudgetTable()
Dim dbFilePath As String
Dim db As DAO.Database
Dim rs As DAO.Recordset
Dim cell As Range
Dim Year As String
Dim SQL As String
'For Each cell In Range("A1:A100")
'If InStr(1, cell.Name, "SQL", vbTextCompare) > 0 Then
Year = Sheets("Report").Range("Year").Value
SQL = Sheets("Report").Range("BudgetSQL").Value
dbFilePath = "H:\CORP\CFR-2011_to_Current\Budget\2015\Budget Variance\Budget Variance - Pivot\Test\More Tests\Administrative\Database\" & Year & " Budget.accdb"
Set db = Access.DBEngine.OpenDatabase(dbFilePath, False, True)
Set rs = db.OpenRecordset(SQL)
Sheets("Budget Table").Range("a2:y50000").ClearContents
Sheets("Budget Table").Range("A2").CopyFromRecordset rs
db.Close
Sheets("Report").PivotTables("BudgetDetail").RefreshTable
'End If
'Next
End Sub
And here's the new code:
Function BuildSQL(FieldNames As Range, Table As Range, PageFilters As Range)
Application.Volatile
Dim cell As Range
'Starts SQL statement
BuildSQL = "SELECT "
'Adds field names to SELECT clause of SQL statement
For Each cell In FieldNames
If cell.Value <> "" Then
BuildSQL = BuildSQL & "[" & Table.Offset(0, 2).Value & "]." & "[" & cell.Value & "]" & ", "
End If
Next
'Chops off trailing "," on end of SQL statement
BuildSQL = Mid(BuildSQL, 1, Len(BuildSQL) - 2)
'Adds FROM clause, table name, and WHERE clause
BuildSQL = BuildSQL & " FROM " & "[" & Table.Offset(0, 2).Value & "]" & " WHERE "
'Adds criteria to SQL statement's WHERE clause
For Each cell In PageFilters
If cell.Value <> "" Then
BuildSQL = BuildSQL & "[" & cell.Value & "] " & cell.Offset(0, 1) & " '" & cell.Offset(0, 2).Value & "'" & " " & cell.Offset(1, -1).Value & " "
End If
Next
'Chops off trailing " AND" and add ";" on end of SQL statement
BuildSQL = Mid(BuildSQL, 1, Len(BuildSQL) - 2) & ";"
End Function
Sub GetBudgetTable()
Dim dbFilePath As String
Dim db As DAO.Database
Dim rs As DAO.Recordset
Dim cell As Range
Dim Year As String
Dim SQL As String
Year = Sheets("Report").Range("Year").Value
SQL = Sheets("Report").Range("BudgetSQL").Value
'pulls budget
dbFilePath = "H:\CORP\CFR-2011_to_Current\Budget\2015\Budget Variance\Budget Variance - Pivot\Test\More Tests\Administrative\Database\" & Year & " Budget.accdb"
Set db = Access.DBEngine.OpenDatabase(dbFilePath, False, True)
Set rs = db.OpenRecordset(SQL)
Sheets("Budget Table").Range("A2:AJ80000").ClearContents
Sheets("Budget Table").Range("A2").CopyFromRecordset rs
db.Close
'pulls actuals
dbFilePath = "H:\CORP\CFR-2011_to_Current\Budget\2015\Budget Variance\Budget Variance - Pivot\Test\More Tests\Administrative\Database\" & Year & " Actuals - Summary.accdb"
Set db = Access.DBEngine.OpenDatabase(dbFilePath, False, True)
Set rs = db.OpenRecordset(SQL)
Sheets("Budget Table").Range("A2").End(xlDown).Offset(1, 0).CopyFromRecordset rs
db.Close
Sheets("Report").PivotTables("Pivot").RefreshTable
End Sub
Sub ActualDrilldown()
'http://stackoverflow.com/questions/34804259/vba-code-to-return-pivot-table-cells-row-column-and-page-fields-and-items/34830798?noredirect=1#comment57563829_34830798
Dim pvtCell As Excel.PivotCell
Dim pvtTable As Excel.PivotTable
Dim pvtField As Excel.PivotField
Dim pvtItem As Excel.PivotItem
Dim pvtParentItem As Excel.PivotField
Dim i As Long
Dim SQL As String
Dim dict As Scripting.Dictionary
Set dict = New Scripting.Dictionary
dict.Add "Jan", "Jan"
dict.Add "Feb", "Feb"
dict.Add "Mar", "Mar"
dict.Add "Apr", "Apr"
dict.Add "May", "May"
dict.Add "Jun", "Jun"
dict.Add "Jul", "Jul"
dict.Add "Aug", "Aug"
dict.Add "Sep", "Sep"
dict.Add "Oct", "Oct"
dict.Add "Nov", "Nov"
dict.Add "Dec", "Dec"
On Error Resume Next
Set pvtCell = ActiveCell.PivotCell
If Err.Number <> 0 Then
MsgBox "The cursor needs to be in a pivot table"
Exit Sub
End If
On Error GoTo 0
If pvtCell.PivotCellType <> xlPivotCellValue Then
MsgBox "The cursor needs to be in a Value field cell"
Exit Sub
End If
SQL = "SELECT * FROM [Actual Detail] WHERE "
'Checks if PivotField.SourceName contains a month. If not, exit sub; otherwise, adds Value Field Source to SQL statement
If dict.Exists(Left(pvtCell.PivotField.SourceName, 3)) = False Then
MsgBox "A month field must be in the column field of the active pivot cell before drilling.", vbOKOnly
Exit Sub
End If
SQL = SQL & "[" & Left(pvtCell.PivotField.SourceName, 3) & "]" & "IS NOT NULL AND "
'Adds rowfields and rowitems to SQL statement
For i = 1 To pvtCell.RowItems.Count
Set pvtParentItem = pvtCell.RowItems(i).Parent
SQL = SQL & "[" & pvtParentItem.Name & "]" & "=" & "'" & pvtCell.RowItems(i).Name & "'" & " AND "
Next i
'Adds columnfields and columnitems to SQL statement
For i = 1 To pvtCell.ColumnItems.Count
Set pvtParentItem = pvtCell.ColumnItems(i).Parent
SQL = SQL & "[" & pvtParentItem.Name & "]" & "=" & "'" & pvtCell.ColumnItems(i).Name & "'" & " AND "
Next i
'Chops off trailing "AND" on end of SQL statement
SQL = Mid(SQL, 1, Len(SQL) - 5) & ";"
Debug.Print SQL
End Sub
I know the code is long and isn't pretty, but if you want the full information, there it is.
I appreciate and thank you for your help!
I figured it out! There were two things I needed to do:
1) I added ActiveWorkbook to the subs code where applicable.
2) This was the tricky part - I realized I have to remove the sub from the Excel ribbon and then add it back. Apparently, when you update a sub in the add-in, the button on the Excel ribbon that runs that sub does not update. You have to remove the button from the Excel ribbon and add it back on.
After doing both of these steps, the add-in worked correctly.
I sure hope there is a way around having to manually remove and add the add-in sub back each time I make a change to the add-in. I'll google this and maybe open up a new question thread.
I'm trying to make a loop that (among other things) inserts a date and then in each row, adds a month to that date. It is not appending the first date properly. The date is a DLookup from a date field in a query, so I think it should work as a date. And I don't see anything wrong with my SQL statement. But when this runs the date shows up in the table as 12/30/1899 and if you click on it, it changes to 12:03:34 AM. It's supposed to be 5/1/15. Nothing I've tried to get this to work has given me any other results.
Here's my code, please note: there's probably a couple other things wrong with my overall code I'm sure, but I'm focusing on this date problem for now. Feel free to point out whatever you find, though.
Private Sub AmortButton_Click()
DoCmd.SetWarnings False
Dim Account As Long: Account = DLookup("[L#]", "qry_info4amort") 'working
Dim StartDate As Date: StartDate = CDate(DLookup("PaidToDate", "qry_info4amort")) 'NOT WORKING
Dim InterestRate As Double: InterestRate = DLookup("IntCur", "qry_info4amort") 'working
Dim piConstant As Integer: piConstant = DLookup("[P&IConstant]", "qry_info4amort")
Dim UPB As Currency: UPB = DLookup("UPB", "qry_info4amort") 'working
Dim tempUPB As Currency: tempUPB = UPB 'working (just to establish variable)
Dim AmortInterest As Currency: AmortInterest = 0 'working (just to establish variable)
Dim AmortPrincipal As Currency: AmortPrincipal = 0 'working (just to establish variable)
Dim Ranking As Integer: Ranking = 1 'working (just to establish variable)
Dim PaymentLoop As Integer: PaymentLoop = 1 'working (just to establish variable)
Dim PaymentNumber As Integer: PaymentNumber = DLookup("NumPmts", "qry_info4amort") 'working
Dim tempInterest As Integer: tempInterest = 0 'working (just to establish variable)
Do While PaymentLoop <= PaymentNumber 'working
tempInterest = Round(tempUPB * (InterestRate / 12), 2)
tempUPB = Round(tempUPB - (piConstant - tempInterest), 2)
AmortPrincipal = AmortPrincipal + (piConstant - tempInterest)
AmortPrincipal = (piConstant - tempInterest)
AmortInterest = AmortInterest + tempInterest
DoCmd.RunSQL "INSERT INTO tbl_AmortizationTest ([L#],[Payment#],[PaymentDate],[UPB],[Interest],[Principal],[TotalPayment],[InterestRate],[TempUPB],[Ranking]) " & _
"VALUES (" & Account & "," & PaymentLoop & "," & StartDate & "," & UPB & "," & tempInterest & "," & AmortPrincipal & "," & (tempInterest + AmortPrincipal) & "," & InterestRate & "," & tempUPB & "," & Ranking & ")"
UPB = tempUPB
StartDate = DateAdd("m", 1, StartDate) 'NOT WORKING
PaymentLoop = PaymentLoop + 1 'working
Ranking = Ranking + 1 'working
Loop
MsgBox "Done!"
DoCmd.SetWarnings True
End Sub
First, if PaidToDate is of data type Date, retrieve your date as is:
StartDate = DLookup("PaidToDate", "qry_info4amort")
If it is a string, CDate or DateValue will do:
StartDate = DateValue(DLookup("PaidToDate", "qry_info4amort"))
Second, format a proper string expression for the date when concatenating it into SQL:
... PaymentLoop & ",#" & Format(StartDate, "yyyy\/mm\/dd") & "#," & UPB ...
Instead of using CDate() around your DLookup("PaidToDate", "qry_info4amort") you are probably going to have to pull out the relevant parts piece by piece...
StartDate = DateSerial(<year>, <month>, <day>)
For example, if DLookup("PaidToDate", "qry_info4amort") returns 05012015 then you could do:
StartDate = DateSerial(Mid(DLookup("PaidToDate", "qry_info4amort"),5,4), Left(DLookup("PaidToDate", "qry_info4amort"),2), Mid(DLookup("PaidToDate", "qry_info4amort"),3,2))
If the DLookup("PaidToDate", "qry_info4amort") returns a value with / in it, then you will have to use some Instr() functions... More on that here.