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
Related
Original code link: MS Access - Convert rows values into columns values
I have a follow up to a question where the answer didn't completely resolve, but got super close. It was asked at the original code link above. It's the single page on the net that actually addresses the issue of transposing multiple values in a one-to-many relationship set of columns to a single row for each related value in a dynamic manner specifically using VBA. Variations of this question have been asked about a dozen times on this site and literally none of the answers goes as far as Vlado did (the user that answered), which is what's necessary to resolve this problem.
I took what Vlado posted in that link, adjusted it for my needs, did some basic cleanup, worked through all the trouble-shooting and syntax problems (even removed a variable declared that wasn't used: f As Variant), and found that it works almost all the way. It generates the table with values for the first two columns correctly, iterates the correct number of variable count columns with headers correctly, but fails to populate the values within the cells for each of the related "many-values". So close!
In order to get it to that point, I have to comment-out db.Execute updateSql portion of the Transpose Function; 3rd to last row from the end. If I don't comment that out, it still generates the table, but it throws a Run-Time Error 3144 (Syntax error in UPDATE statement) and only creates the first row and all the correct columns with correct headers (but still no valid values inside the cells). Below is Vlado's code from the link above, but adjusted for my field name needs, and to set variables at the beginning of each of the two Functions defined. The second Function definitely works correctly.
Public Function Transpose()
Dim DestinationCount As Integer, i As Integer
Dim sql As String, insSql As String, fieldsSql As String, updateSql As String, updateSql2 As String
Dim db As DAO.Database, rs As DAO.Recordset, grp As DAO.Recordset
Dim tempTable As String, myTable As String
Dim Var1 As String, Var2 As String, Var3 As String, Var4 As String
tempTable = "Transposed" 'Value for Table to be created with results
myTable = "ConvergeCombined" 'Value for Table or Query Source with Rows and Columns to Transpose
Var1 = "Source" 'Value for Main Rows
Var2 = "Thru" 'Value for Additional Rows
Var3 = "Destination" 'Value for Columns (Convert from Rows to Columns)
Var4 = "Dest" 'Value for Column Name Prefixes
DestinationCount = GetMaxDestination
Set db = CurrentDb()
If Not IsNull(DLookup("Name", "MSysObjects", "Name='" & tempTable & "'")) Then
DoCmd.DeleteObject acTable, tempTable
End If
fieldsSql = ""
sql = "CREATE TABLE " & tempTable & " (" & Var1 & " CHAR," & Var2 & " CHAR "
For i = 1 To DestinationCount
fieldsSql = fieldsSql & ", " & Var4 & "" & i & " INTEGER"
Next i
sql = sql & fieldsSql & ")"
db.Execute (sql)
insSql = "INSERT INTO " & tempTable & " (" & Var1 & ", " & Var2 & ") VALUES ("
Set grp = db.OpenRecordset("SELECT DISTINCT " & Var1 & ", " & Var2 & " FROM " & myTable & " GROUP BY " & Var1 & ", " & Var2 & "")
grp.MoveFirst
Do While Not grp.EOF
sql = "'" & grp(0) & "','" & grp(1) & "')"
db.Execute insSql & sql
Set rs = db.OpenRecordset("SELECT * FROM " & myTable & " WHERE " & Var1 & " = '" & grp(0) & "' AND " & Var2 & " = '" & grp(1) & "'")
updateSql = "UPDATE " & tempTable & " SET "
updateSql2 = ""
i = 0
rs.MoveFirst
Do While Not rs.EOF
i = i + 1
updateSql2 = updateSql2 & "" & Var3 & "" & i & " = " & rs(2) & ", " ' <------- MADE CHANGE FROM (3) to (2)
rs.MoveNext
Loop
updateSql = updateSql & Left(updateSql2, Len(updateSql2) - 1) & " WHERE " & Var1 & " = '" & grp(0) & "' AND " & Var2 & " = '" & grp(1) & "'"
db.Execute updateSql ' <-- This is the point of failure
grp.MoveNext
Loop
End Function
Public Function GetMaxDestination()
Dim rst As DAO.Recordset, strSQL As String
myTable = "ConvergeCombined" 'Value for Table or Query Source with Rows and Columns to Transpose
Var1 = "Source" 'Value for Main Rows
Var2 = "Thru" 'Value for Additional Rows
Var3 = "Destination" 'Value for Columns (Convert from Rows to Columns)
strSQL = "SELECT MAX(CountOfDestination) FROM (SELECT Count(" & Var3 & ") AS CountOfDestination FROM " & myTable & " GROUP BY " & Var1 & ", " & Var2 & ")"
Set rst = CurrentDb.OpenRecordset(strSQL)
GetMaxDestination = rst(0)
rst.Close
Set rst = Nothing
End Function
Sample Table:
Sample Data:
Add a Debug.Print updateSql before that Execute line and will see improper syntax in SQL statement. Need to trim trailing comma from updateSql2 string. Code is appending a comma and space but only trims 1 character. Either eliminate space from the concatenation or trim 2 characters.
Left(updateSql2, Len(updateSql2) - 2)
Concatenation for updateSql2 is using Var3 instead of Var4.
Source field is a number type in ConvergeCombined and this triggers a 'type mismatch' error in SELECT statement to open recordset because of apostrophe delimiters Var1 & " = '" & grp(0) & "' - remove them from two SQL statements.
Also, Source value is saved to a text field in Transposed, make it INTEGER instead of CHAR in the CREATE TABLE action.
So with the help of a friend I figured it out. It turns out I needed two Functions because the one-to-many relationships go both directions in my case. I explain below what needs to happen in comments for this to work. Essentially I went with the second comment under the question I posed (pre-defining field names in static tables because there is a limited number of fields that any person will need - it can't exceed 256 fields anyway, but it isn't always practical to use more than a dozen or so fields - this way allows for both and at the same time to simplify the code significantly).
This solution actually works - but it's dependent on having tables (or queries in my situation) labeled ConvergeSend and ConvergeReceive. Also, it's important to note that the instances where the Destination is single and the Source is plural, the table or query (ConvergeSend/ConvergeReceive) must have the Destination value as a column TO THE LEFT of the iterated Source columns. This is also true (but reverse naming convention) for the other table/query (the Source column must be TO THE LEFT of the iterated Destination columns).
' For this code to work, create a table named "TransposedSend" with 8 columns: Source, Destination1, Destination2,...Destination7; OR however many you need
' Save the table, Edit it, change all field values to Number and remove the 0 as Default Value at the bottom
' Not changing the field values to Number causes the Insert Into function to append trailing spaces for no apparent reason
Public Function TransposeSend()
Dim i As Integer
Dim rs As DAO.Recordset, grp As DAO.Recordset
CurrentDb.Execute "DELETE * FROM TransposedSend", dbFailOnError
CurrentDb.Execute "INSERT INTO TransposedSend (Source) SELECT DISTINCT Source FROM ConvergeSend GROUP BY Source", dbFailOnError
Set grp = CurrentDb.OpenRecordset("SELECT DISTINCT Source FROM ConvergeSend GROUP BY Source")
grp.MoveFirst
Do While Not grp.EOF
Set rs = CurrentDb.OpenRecordset("SELECT Source, Destination, [Destination App Name] FROM ConvergeSend WHERE Source = " & grp(0))
i = 0
rs.MoveFirst
Do While Not rs.EOF
i = i + 1
CurrentDb.Execute "UPDATE TransposedSend SET Destination" & i & " = '" & rs(1) & "', [Destination" & i & " App Name] = '" & rs(2) & "'" & " WHERE Source = " & grp(0)
rs.MoveNext
Loop
grp.MoveNext
Loop
End Function
' For this code to work, create a table named "TransposedReceive" with 8 columns: Destination, Source1, Source2,...Source7; OR however many you need
' Save the table, Edit it, change all field values to Number and remove the 0 as Default Value at the bottom
' Not changing the field values to Number causes the Insert Into function to append trailing spaces for no apparent reason
Public Function TransposeReceive()
Dim i As Integer
Dim rs As DAO.Recordset, grp As DAO.Recordset
CurrentDb.Execute "DELETE * FROM TransposedReceive", dbFailOnError
CurrentDb.Execute "INSERT INTO TransposedReceive (Destination) SELECT DISTINCT Destination FROM ConvergeReceive GROUP BY Destination", dbFailOnError
Set grp = CurrentDb.OpenRecordset("SELECT DISTINCT Destination FROM ConvergeReceive GROUP BY Destination")
grp.MoveFirst
Do While Not grp.EOF
Set rs = CurrentDb.OpenRecordset("SELECT Destination, Source, [Source App Name] FROM ConvergeReceive WHERE Destination = " & grp(0))
i = 0
rs.MoveFirst
Do While Not rs.EOF
i = i + 1
CurrentDb.Execute "UPDATE TransposedReceive SET Source" & i & " = '" & rs(1) & "', [Source" & i & " App Name] = '" & rs(2) & "'" & " WHERE Destination = " & grp(0)
rs.MoveNext
Loop
grp.MoveNext
Loop
End Function
I'm trying to do something basic:
Take 2 dates [startD] and [endD] from a accdb file.
Move them forward one month each
save the new dates as short dates in the respective record.
I'm doing this all by VBA
The issue is that it is showing the correct SQL String (if i do msgbox sql) however when it saves, it is saving as a general date with time and is the wrong value!
*Note: I'm in Australia so I have a format section to make sure the date saves correctly.
I have tried using DateValue() and Formatting the date too.
Dim frq As Integer
Dim wks As Integer
Dim CurAcc As Integer
Dim CurAccEnd As Date
Dim Days As Integer
Dim curaccvalue As Currency
Dim cardtype As Integer
Dim cardcharged As Integer
cardtype = 0
cardcharged = 0
CurAcc = Me.ID
curraccvalue = DLookup("Acccurvalue", "Accounts", "[ID] = " & CurAcc)
Curraccend = DLookup("Accend", "Accounts", "[ID] = " & CurAcc)
frq = DLookup("freqid", "Accounts", "[ID] = " & CurAcc)
wks = DLookup("freqvalue", "tblfrequency", "FrequencyID = " & frq)
Days = wks * 7
strsql = "UPDATE Accounts SET AccStart = " & Date & " , AccEND = " &
Curraccend + Days & " , AccCurValue = 0.00 WHERE ID = " & CurAcc
MsgBox strsql
DoCmd.RunSQL strsql
When implicitly converting a date to a string, your regional settings are used, but in a SQL string, a date must be in the American format.
To avoid this, I suggest to do the update in just one query:
Dim strSql As String
strSql = "UPDATE Accounts " & _
"INNER JOIN tblfrequency ON Accounts.freqid = tblfrequency.FrequencyID SET " & _
"AccStart = Date(), " & _
"AccEND = DateAdd(""w"", tblfrequency.freqvalue, Accounts.Accend), " & _
"AccCurValue = 0.00 WHERE ID = " & Me.ID
MsgBox strSql
DoCmd.RunSQL strSql
I have a table, which was pulled out of some XML data. I'm trying to do a cross reference, so I can line out a plan for organizing the data. This 1 table has a list of variables. Fields of different data types, computations, as well as dialogs. One of the columns has options. If the data type of the variable is a dialog, its options has a list of variables, separated by a semi-colon.
So the main table has a structure like so:
For the dialog records I need to look through their options column and insert records into a normalized table. For each field, in that column, I want to add a record with that dialog name, and the ID of the row in that table (I added a PK to the table). For instance, in the dialog record, Options column, there is a field in there called BusinessName TE. I need to search this main table for the PK ID of the row that has a variable name of the same. I need to put that record's ID with the name of the dialog, and insert both into a new table I set up. This will create a cross reference for me, so I can know which variables are being used by which dialogs.
I appreciate any help anyone can give. I see stuff about using a split function, arrays and looping through to get each value, but the examples I'm finding are for strings, not a column in a table.
Thanks!
Edit: Adding in the VBA code I'm working with. I attached it to a button on a form, just so I could click to run it.
Private Sub RunParse_Click()
Dim db As DAO.Database
Dim rs As Recordset
Set db = CurrentDb()
Dim sqlStr, insertSQL, arrayVal As String
Dim TestArray As Variant
Dim Options As String
Dim Dialog As String
Dim FieldName As Long
Dim i As Integer
sqlStr = "SELECT [MASTER Fields].Options,[MASTER Fields].[Variable Name] FROM [MASTER Fields] WHERE ((([MASTER Fields].[Variable Type])='dialog'));"
Set rs = db.OpenRecordset(sqlStr)
rs.MoveLast
rs.MoveFirst
Do While Not rs.EOF
Options = rs.Fields(0)
Dialog = rs.Fields(1)
If InStr(Options, ";") Then
TestArray = Split(Options, ";")
For i = 0 To UBound(TestArray) - LBound(TestArray) + 1
If TestArray(i) <> "" Then
arrayVal = TestArray(i)
FieldName = DLookup("ID", "MASTER Fields", "[Variable Name] = " & "'" & arrayVal & "'")
insertSQL = "INSERT INTO FieldTemplatesUse(FID, TemplateAK) " _
& "VALUES(""" & FieldName & """, """ & Dialog & """)"
DoCmd.RunSQL (insertSQL)
End If
Next i
End If
rs.MoveNext
Loop
End Sub
right now on the line that says
If TestArray(i) <> "" Then
creates an error ""
If anyone can help, I'd really appreciate it!
Another Edit:
Parfait figured out my issue. I'm posting the final code I am using, in case it helps someone else! p.s. I added a condition to check if the dlookup is successful, and trap failures in a failures table. That way I can check those out afterward.
Private Sub RunParse_Click()
Dim db As DAO.Database
Dim rs As Recordset
Set db = CurrentDb()
Dim sqlStr, insertSQL, arrayVal As String
Dim TestArray As Variant
Dim Options As String
Dim Dialog As String
Dim FieldName As Long
Dim i As Integer
sqlStr = "SELECT [Master Fields].Options,[Master Fields].[Variable Name] FROM [Master Fields] WHERE ((([Master Fields].[Variable Type])='dialog'));"
Set rs = db.OpenRecordset(sqlStr)
rs.MoveLast
rs.MoveFirst
Do While Not rs.EOF
Options = rs.Fields(0)
Dialog = rs.Fields(1)
If InStr(Options, ";") Then
TestArray = Split(Options, ";")
For i = 0 To UBound(TestArray) - LBound(TestArray)
If TestArray(i) <> "" Then
arrayVal = TestArray(i)
If Not (IsNull(DLookup("ID", "Master Fields", "[Variable Name] = " & "'" & arrayVal & "'"))) Then
FieldName = DLookup("ID", "Master Fields", "[Variable Name] = " & "'" & arrayVal & "'")
insertSQL = "INSERT INTO FieldTemplatesUse(FID, TemplateAK) " _
& "VALUES(""" & FieldName & """, """ & Dialog & """)"
DoCmd.RunSQL (insertSQL)
'MsgBox "Adding ID = " & FieldName & "for Dialog: " & Dialog & "Now"
Else
insertSQL = "INSERT INTO tblFieldsNotFound(Dialog, FieldNotFound) " _
& "VALUES(""" & Dialog & """, """ & arrayVal & """)"
DoCmd.RunSQL (insertSQL)
End If
End If
Next i
End If
rs.MoveNext
Loop
MsgBox "All Done!"
End Sub
I have fields which have as name a the date of delivery, as you can see here:
I have around 75 columns like that. I have a bug when I want to compute the value P1 because it does not find the field. BTW, I have very stranges values for my coefficients T1, T2 (which are dates) and thus A and B which are datediff. There is the code:
Sub vcm_fc()
Dim db As Database, T As Date, longest As Integer, nearest_date As Date, rsb As DAO.Recordset, strsqlb As String
Dim strsqla As String, rsa As Recordset, maturity As Date, T1 As Date, T2 As Date, P1 As Double, P2 As Double
Dim a As Integer, B As Integer, j As Integer, rsc As DAO.Recordset, strqlc As String, settlementbis As String
Dim settlement As String, maturitybis As Date, ym As Integer, ymbis As Integer
Set db = CurrentDb()
T = DateSerial(2020, 8, 15)
nearest_date = DFirst("PricingDate", "fc_historical")
longest = DateDiff("m", nearest_date, T)
db.Execute "CREATE TABLE time_series " _
& "(PricingDate CHAR);"
db.Execute " INSERT INTO time_series " _
& "SELECT PricingDate " _
& "FROM fc_historical " _
& "ORDER BY PricingDate;"
For i = 1 To longest
db.Execute " ALTER TABLE time_series " _
& "ADD COLUMN F_" & i & " Number;"
strsqla = "SELECT PricingDate, F_" & i & " FROM time_series ORDER BY PricingDate"
Set rsa = db.OpenRecordset(strsqla, dbOpenDynaset)
rsa.MoveFirst
rsa.Delete 'delete the first row which is blank when the time series table is created'
rsa.MoveFirst
While (Not rsa.EOF())
rsa.Edit
maturity = DateAdd("m", i, rsa.Fields("PricingDate").Value)
ym = Year(maturity) - 2000
settlement = "1/" & Month(maturity) & "/" & ym
strsqlb = "SELECT Pricingdate, " & settlement & " FROM fc_historical ORDER BY PricingDate;"
Set rsb = db.OpenRecordset(strsqlb, dbOpenDynaset)
rsb.MoveLast
T1 = rsb.Fields("PricingDate").Value
maturitybis = DateAdd("m", i, maturity)
ymbis = Year(maturitybis) - 2000
settlementbis = "1/" & Month(maturitybis) & "/" & ymbis
strsqlc = "SELECT Pricingdate, " & settlementbis & " FROM fc_historical ORDER BY PricingDate;"
Set rsc = db.OpenRecordset(strsqlc, dbOpenDynaset)
rsc.MoveLast
T2 = rsc.Fields("PricingDate").Value
a = DateDiff("d", T1, rsa.Fields("PricingDate").Value)
B = DateDiff("d", rsa.Fields("PricingDate").Value, T2)
P1 = rsb.Fields(settlement).Value
P2 = rsc.Fields(settlementbis).Value
rsa.Fields("F_" & i) = (P1 * B + P2 * a) / (a + B)
rsa.Update
rsa.MoveNext
Wend
Next i
End Sub
Have added as an answer so I can get the format for the code. This code will take your date field names and place them as record values - you may need to muck around with the fld.Name to make sure it isn't US date format (8th Jan, 9th Jan, etc for your table example) along with the price for that date.
Sub Put_Field_Names_As_Record_Values()
Dim DB As DAO.Database
Dim OldTable As DAO.TableDef
Dim fld As DAO.Field
Set DB = CurrentDb()
Set OldTable = DB.TableDefs("time_series")
DoCmd.SetWarnings False
For Each fld In OldTable.Fields
If IsDate(fld.Name) Then
Debug.Print fld.Name & " : " & SQLDate(fld.Name)
DoCmd.RunSQL "INSERT INTO MyNewTable (PricingDate, SettlementDate, Price) " & _
"SELECT PricingDate," & SQLDate(fld.Name) & ", [" & fld.Name & "] FROM time_series"
End If
Next fld
DoCmd.SetWarnings True
End Sub
Function SQLDate(varDate As Variant) As String
'Purpose: Return a delimited string in the date format used natively by JET SQL.
'Argument: A date/time value.
'Note: Returns just the date format if the argument has no time component,
' or a date/time format if it does.
'Author: Allen Browne. allen#allenbrowne.com, June 2006.
If IsDate(varDate) Then
If DateValue(varDate) = varDate Then
SQLDate = Format$(varDate, "\#mm\/dd\/yyyy\#")
Else
SQLDate = Format$(varDate, "\#mm\/dd\/yyyy hh\:nn\:ss\#")
End If
End If
End Function
You can then run queries on the table:
SELECT SUM(Price)
FROM MyNewTable
WHERE PricingDate<=#07/16/2014# AND SettlementDate=#01/08/2014#
Edit: Test on a copy of your database!!
Edit 2: Manually create the MyNewTable and set PricingDate and SettlementDate as key fields.
I've updated to convert the field name into the correct date - http://allenbrowne.com/ser-36.html
On my test it converted all dates to the first of each month correctly.
Use properly formatted date expressions:
settlementbis = "#" & CStr(ymbis) & "/" & CStr(Month(maturitybis)) & "/1#"
And do listen to Darren about normalisation.
Our requirement -
We have few suppliers and we want to generate a monthly report of purchases from each supplier during the month and export to excel. I think the solution is to create a parameter query where I can pass the value of the supplier ID, Month and Year. The list of supplier keeps changing and is stored in a separate table.
So, basically, I should be able to sequentially read the supplier ID from that table and pass as a parameter to my query to generate the report for that supplier.
The closest solutions that I found for my requirement was on (which are similar in nature) -
Exporting Recordset to Spreadsheet
http://answers.microsoft.com/en-us/office/forum/office_2010-customize/filtering-a-query-used-by-docmdtransferspreadsheet/06d8a16c-cece-4f03-89dc-89d240436693
Why I think there could be a better solution -
In the suggested solution, we are creating multiple queries and deleting these. Conceptually, I feel there should be a way to create a parameter query and use the do while loop to sequentially pass the value of the parameter (DeptName in above example) to the query and export the results to excel.
I should be able to achieve this if I can use vba to pass value to a parameter query. And that is what I have not yet been able to figure out.
Update on 24-Feb -
Following is the code that I have written -
Private Sub Monthly_Supplier_Sales_Report_Click()
Dim strDirectoryPath As String
Dim DateFolderName As String
DateFolderName = Format$((DateSerial(year(Date), month(Date), 1) - 1), "YYYY MM")
strDirectoryPath = "C:\dropbox\Accounting\Sales Reports\" & DateFolderName
If Dir(strDirectoryPath, vbDirectory) = "" Then MkDir strDirectoryPath
Dim Filename As String
Dim strSQL1 As String
Dim strSQL2 As String
Dim DesignerCode As String
Dim month1 As String
Dim year1 As Integer
Dim Query1 As DAO.QueryDef
Dim query2 As DAO.QueryDef
Dim rsDesigner As DAO.Recordset
Set rsDesigner = CurrentDb.OpenRecordset("Designer Details Master")
Do While Not rsDesigner.EOF
DesignerCode = rsDesigner![Designer Code]
month1 = "Jan" 'right now hardcoded, will call this programatically
year1 = 2014 'right now hardcoded, will call this programatically
strSQL1 = "SELECT * FROM [Sales Report Generation Data] WHERE [designer code] = '" & DesignerCode & "' AND [Shipping Month]= '" & month1 & "' AND [Shipping Year]=" & year1
strSQL2 = "SELECT * FROM [Sales Report Generation - Monthwise Inventory Snapshot] WHERE [designer code] = '" & DesignerCode & "' AND [Snapshot Month]= '" & month1 & "' AND [Snapshot Year]= " & year1
Set Query1 = CurrentDb.CreateQueryDef(Name:="TempSalesQuery", SQLText:=strSQL1)
Set query2 = CurrentDb.CreateQueryDef(Name:="TempInventoryQuery", SQLText:=strSQL2)
Filename = strDirectoryPath & "\" & DesignerCode & Format$(Now(), " yyyy mm") & ".xls"
DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel9, "TempSalesQuery", Filename, False, "Sales Report"
DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel9, "TempInventoryQuery", Filename, False, "Inventory"
CurrentDb.QueryDefs.Delete "TempSalesQuery"
CurrentDb.QueryDefs.Delete "TempInventoryQuery"
rsDesigner.MoveNext
Loop
End Sub
Instead, The logic I want to apply is -
Do While Not
assign Value to Parameter 1 = rsDesigner![Designer Code]
assign Value to Parameter 2 = Month1
assign Value to Parameter 3 = Year1
Run the two Parameter queries, for which about three parameters are the input value and export to excel in respective sheets.
Loop
Just that I have not yet been able to figure out - how to achieve this.
Here is one solution. Note that I created Functions that the two queries will use.
Just create your two queries and save them (see sample SQL below), add your code to pick dates and everything should be fine.
Option Compare Database
Option Explicit
Dim fvShipMonth As String
Dim fvShipYear As Integer
Dim fvDesignerCode As String
Public Function fShipMonth() As String
fShipMonth = fvShipMonth
End Function
Public Function fShipYear() As Integer
fShipYear = fvShipYear
End Function
Public Function fDesignerCode() As String
fDesignerCode = fvDesignerCode
End Function
Private Sub Monthly_Supplier_Sales_Report_Click()
Dim Filename As String
Dim strSQL1 As String
Dim strSQL2 As String
Dim DesignerCode As String
Dim month1 As String
Dim year1 As Integer
Dim rsDesigner As DAO.Recordset
'SAMPLE SQL
'SELECT * FROM [Sales Report Generation Data] " & _
'WHERE [designer code] = '" & fDesignerCode() & "' AND [Shipping Month]= '" & fShipMonth() & "' AND [Shipping Year]=" & fShipYear()
fvShipMonth = "Jan"
fvShipYear = 2014
Set rsDesigner = CurrentDb.OpenRecordset("Designer Details Master")
Do While Not rsDesigner.EOF
fvDesignerCode = rsDesigner![Designer Code]
Filename = strDirectoryPath & "\" & DesignerCode & Format$(Now(), " yyyy mm") & ".xls"
DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel9, "<your Query 1>", Filename, False, "Sales Report"
DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel9, "<your Query 2>", Filename, False, "Inventory"
rsDesigner.MoveNext
Loop
rsDesigner.Close
Set rsDesigner = Nothing
End Sub
Open your database
Create a NEW module
Paste the following code
Place your cursor inside Function TEST_MY_CODE()
Press F5
Paste the results from the immediate window in your response.
Option Compare Database
Option Explicit
Dim fvShipMonth As String
Dim fvShipYear As Integer
Dim fvDesignerCode As String
Public Function fShipMonth() As String
fShipMonth = fvShipMonth
End Function
Public Function fShipYear() As Integer
fShipYear = fvShipYear
End Function
Public Function fDesignerCode() As String
fDesignerCode = fvDesignerCode
End Function
Function TEST_MY_CODE()
My_Click_EVENT ' Test the code I provided
End Function
Private Sub My_Click_EVENT()
Dim month1 As String
Dim year1 As Integer
fvShipMonth = "Jan"
fvShipYear = 2014
Debug.Print "**** START TEST ****"
Debug.Print "fvShipMonth = " & fvShipMonth
Debug.Print "fvShipYear = " & fvShipYear
Debug.Print "fShipMonth() = " & fShipMonth()
Debug.Print "fShipYear() = " & fShipYear()
Debug.Print "**** END TEST ****"
End Sub