VBA: Error 3265 - "Item not found in this collection" - sql

In Access 2016 I'm trying to open a recordset and save data from it in other variables, but I keep getting this error.
The program itself has more parts, but I only get error in this one, it just update data on its database.
This is my code:
Option Compare Database
Option Explicit
Private Sub btnValidateTimesheet_Click()
' Update timesheet to "Justificat"
Dim intIdTimesheet As Integer
If IsNull(cmbDraftTimesheets.Value) Then
MsgBox("You have to select a timesheet that is Borrador")
Exit Sub
End If
intIdTimesheet = cmbDraftTimesheets.Column(0)
DoCmd.SetWarnings False
DoCmd.RunSQL "update Timesheets set estat = ""Justificat"" where id=" & intIdTimesheet
DoCmd.SetWarnings True
End Sub
Private Sub btnValidateTimesheetLines_Click()
' We select the timesheet_lines for employee, project, activity and dates selected
' For each justification, a new "Justificat" Timesheet is generated which hang timesheet_lines
' ------------------------------- Variables -------------------------------
Dim dictTsLines As Object
Set dictTsLines = CreateObject("Scripting.Dictionary")
' Form inputs
Dim intCodTreb As Integer
Dim strCodProj As String
Dim dateInici, dateFi As Date
Dim intExercici As Integer
' Query strings
Dim strSQLFrom, strSQLWhere As String
Dim strSQLCount, strSQLJustAct, strSQLTsLines As String
' Recordsets
Dim rsCount, rsJustAct, rsTimesheets, rsTsLines As Recordset
' Aux and others...
Dim continue As Integer
Dim intIdJustificacio, intIdTs As Integer
Dim strActivitat As String
' --------------------------------------- Main ---------------------------------------------
' Taking form data
intCodTreb = cmbTreballador.Column(0)
strCodProj = cmbProjecte.Column(1)
dateInici = txtDataInici.Value
dateFi = txtDataFi.Value
' We check the dates are correct
If IsNull(dateInici) Or IsNull(dateFi) Then
MsgBox("Dates can't be null")
Exit Sub
End If
If dateFi < dateInici Then
MsgBox("Start date must be earlier or the same as final date")
Exit Sub
End If
If year(dateInici) <> year(dateFi) Then
MsgBox("Dates must be in the same year")
Exit Sub
End If
intExercici = year(dateInici)
' Make of the clause FROM and WHERE of the select query of timesheet_lines
strSQLFrom = " from (timesheet_lines tsl " & _
" left join timesheets ts on tsl.timesheet_id = ts.id) " & _
" left join justificacions j on j.id = ts.id_justificacio "
strSQLWhere = " where ts.estat = ""Borrador"" " & _
" and tsl.data >= #" & Format(dateInici, "yyyy/mm/dd") & "# " & _
" and tsl.data <= #" & Format(dateFi, "yyyy/mm/dd") & "# "
If Not IsNull(intCodTreb) Then
strSQLWhere = strSQLWhere & " and tsl.cod_treb = " & intCodTreb
End If
If Not IsNull(strCodProj) Then
strSQLWhere = strSQLWhere & " and j.cod_proj=""" & strCodProj & """ "
End If
' Alert how much timesheet_lines are going to be validated
strSQLCount = "select count(*) " & strSQLFrom & strSQLWhere
Set rsCount = CurrentDb.OpenRecordset(strSQLCount)
Continue Do = MsgBox( rsCount(0) & " registries are going to be validated" & vbNewLine & _
"Do you want to continue?", vbOKCancel)
If continue <> 1 Then
Exit Sub
End If
' We select the tuples Justificacio, Activitat of timesheet_lines selected
strSQLJustAct = "select distinct ts.id_justificacio " & strSQLFrom & strSQLWhere
Set rsJustAct = CurrentDb.OpenRecordset(strSQLJustAct)
Set rsTimesheets = CurrentDb.OpenRecordset("Timesheets")
' A new timesheet is generated for each tupla
Do While Not rsJustAct.EOF
intIdJustificacio = rsJustAct(0)
strActivitat = rsJustAct(1)
rsTimesheets.AddNew
rsTimesheets!data_generacio = Now()
rsTimesheets!estat = "Justificat"
rsTimesheets!Id_justificacio = intIdJustificacio
rsTimesheets!activitat = strActivitat
rsTimesheets!data_inici = dateInici
rsTimesheets!data_fi = dateFi
rsTimesheets!exercici = intExercici
intIdTs = rsTimesheets!Id
rsTimesheets.Update
' We save the related id of the selected timesheet in a dictionary
dictTsLines.Add intIdJustificacio & "_" & strActivitat, intIdTs
rsJustAct.MoveNext
Loop
' We select all the affected timesheet_lines and we update the related timesheet using the dictionary
strSQLTsLines = "select tsl.id, tsl.timesheet_id, ts.id_justificacio, ts.activitat " & strSQLFrom & strSQLWhere
Set rsTsLines = CurrentDb.OpenRecordset(strSQLTsLines)
With rsTsLines
Do While Not .EOF
.EDIT
intIdJustificacio = !Id_justificacio
strActivitat = !activitat
!timesheet_id = dictTsLines.Item(intIdJustificacio & "_" & strActivitat)
.Update
.MoveNext
Loop
End With
rsTimesheets.Close
Set rsCount = Nothing
Set rsJustAct = Nothing
Set rsTimesheets = Nothing
Set rsTsLines = Nothing
End Sub
Debugger: The error is coming up at the line:
strActivitat = rsJustAct(1)
I checked that the data the recordset is saving exists and it does.

Your recordset contains just one column ("select distinct ts.id_justificacio"), but you are trying to read second column strActivitat = rsJustAct(1)
Add requred column to recordset.

Related

Access VBA List not populating Data

I have an Access VBA list box with a rowsource that will not populate. It was working last week and after reopening the DB this week, for some reason it will not show the results of my string.
Private Sub PullData(strType As String)
Dim rst As DAO.Recordset
Dim sSQL As String
On Error GoTo Err_PullData
Set rst = CurrentDb.OpenRecordset("SELECT * FROM TBLactionstaken_ARCHIVE", dbOpenDynaset, dbReadOnly)
Select Case strType
Case "Actions"
If Me.Frame388.Value = 1 Then
Me.lstActionsTaken.RowSource = "SELECT TBLactionstaken_ARCHIVE.RecordNumber, TBLactionstaken_ARCHIVE.ActionTakenID, TBLparticipants.[PartSS#], TBLactionstaken_ARCHIVE.ActionDate, TBLactionstaken_ARCHIVE.ActionStatus, TBLactionstaken_ARCHIVE.ReasonID, " & _
"TBLreasons.Description, TBLactionstaken_ARCHIVE.MANHType, TBLactionstaken_ARCHIVE.ProcessedDate, TBLactionstaken_ARCHIVE.PayOutStatus, " & _
"TBLactionstaken_ARCHIVE.PayOutDate FROM (TBLactionstaken_ARCHIVE INNER JOIN TBLparticipants ON TBLactionstaken_ARCHIVE.RecordNumber = " & _
"TBLparticipants.RecordNumber) INNER JOIN TBLreasons ON TBLactionstaken_ARCHIVE.ReasonID = TBLreasons.ReasonID WHERE " & _
"(((TBLactionstaken_ARCHIVE.ActionDate)<= [Form]![txtEndDate] And (TBLactionstaken_ARCHIVE.ActionDate)>= [Form]![txtEndDate]));"
Me.lstActionsTaken.Requery
ElseIf Me.Frame388.Value = 2 Then
Me.lstActionsTaken.RowSource = ""
Else
MsgBox "No Data Available", vbExclamation, "Archive Search"
Exit Sub
End If
Case "Transactions"
lstActionsTaken.Visible = False
lstTransactions.Visible = True
End Select
Exit_PullData:
Exit Sub
Err_PullData:
MsgBox Err.Description
Resume Exit_PullData
End Sub
The list box is set up with 11 columns. It's not throwing an error and I can use the immediate window to determine that my fields have values.
Try with specificly formatted date expressions:
If Me.Frame388.Value = 1 Then
Me.lstActionsTaken.RowSource = _
"SELECT TBLactionstaken_ARCHIVE.RecordNumber, TBLactionstaken_ARCHIVE.ActionTakenID, TBLparticipants.[PartSS#], TBLactionstaken_ARCHIVE.ActionDate, TBLactionstaken_ARCHIVE.ActionStatus, TBLactionstaken_ARCHIVE.ReasonID, " & _
"TBLreasons.Description, TBLactionstaken_ARCHIVE.MANHType, TBLactionstaken_ARCHIVE.ProcessedDate, TBLactionstaken_ARCHIVE.PayOutStatus, " & _
"TBLactionstaken_ARCHIVE.PayOutDate FROM (TBLactionstaken_ARCHIVE INNER JOIN TBLparticipants ON TBLactionstaken_ARCHIVE.RecordNumber = " & _
"TBLparticipants.RecordNumber) INNER JOIN TBLreasons ON TBLactionstaken_ARCHIVE.ReasonID = TBLreasons.ReasonID WHERE " & _
"(TBLactionstaken_ARCHIVE.ActionDate <= #" & Format(Me!txtEndDate.Value, "yyyy\/mm\/dd") & "# And TBLactionstaken_ARCHIVE.ActionDate >= #" & Format(Me!txtEndDate.Value, "yyyy\/mm\/dd") & "#);"
' Not needed: Me.lstActionsTaken.Requery

Search FlagRequest for single or multiple text combinations

In my inbox there are emails where the sender communicates either single or multiple seminars or event codes.
For example, AI-G167 and/or HR-T245. I flag those emails with category and flag request and this helps me add functionality in my code.
My filter only works when FlagRequest has a single event code and fails when I mark FlagRequest with a delimited value, e.g "AI-G167, HR-T245".
Category_Filter = "[Categories] = 'Seminars' And [FlagRequest] = " & EventCode
Is there any way, my filter could work in this scenario? It means that email would serve my purpose even if there are two different events to be held on a single day at different times.
If Restrict does not support like for .FlagRequest there is InStr.
Option Explicit ' Consider this mandatory
' Tools | Options | Editor tab
' Require Variable Declaration
' If desperate declare as Variant
Sub FlagRequest_multiple_values()
Dim oItems As Items
Dim oItemsRes As Items
Dim Category_Filter As String
Dim Category_Flag_Filter As String
Dim EventCode As String
Dim i As Long
Dim resItemsCount As Long
Dim matchCount As Long
Set oItems = Session.GetDefaultFolder(olFolderInbox).Folders("FlagRequestTest").Items
EventCode = "AI-G167"
'EventCode = "HR-T245"
Debug.Print
Debug.Print "EventCode......: " & EventCode
' with single quotes added to variable
Category_Flag_Filter = _
"[Categories] = 'Seminars' And [FlagRequest] = " & "'" & EventCode & "'"
Debug.Print
Debug.Print "Category_Flag_Filter......: " & Category_Flag_Filter
Set oItemsRes = oItems.Restrict(Category_Flag_Filter)
Debug.Print "Category_Flag_Filter count: " & oItemsRes.Count
Category_Filter = "[Categories] = 'Seminars'"
Debug.Print
Debug.Print "Category_Filter......: " & Category_Filter
Set oItemsRes = oItems.Restrict(Category_Filter)
Debug.Print "Category_Filter count: " & oItemsRes.Count
If oItemsRes.Count > 0 Then
resItemsCount = oItemsRes.Count
For i = 1 To resItemsCount
With oItemsRes(i)
Debug.Print i & " Subject......: " & .Subject
Debug.Print " FlagRequest: " & .FlagRequest
If InStr(.FlagRequest, EventCode) > 0 Then
matchCount = matchCount + 1
Else
Debug.Print " *** No match ***"
End If
End With
Next
End If
Debug.Print matchCount & " matches of " & resItemsCount
End Sub

VBA Query based on multiple "multiple select list boxes" in Access when not selecting an item from one of the multiple select boxes

I have the following vba that creates a query in a test Access database. I have two multiple select list boxes. The issue is, i want to be able to select multiple items from "Me![State]" and none from "Me![Animal]" and be able to run the query. However, this is not possible as the query language is not set up to handle that. It makes me select something from "Me![Animal]".
How do i revise the vba below to allow me to query on both multiple selection list boxes if one of the multiple list boxes does not have anything selected or if both have selections in them?
Private Sub Command6_Click()
Dim Q As QueryDef, DB As Database
Dim Criteria As String
Dim ctl As Control
Dim Itm As Variant
Dim ctl2 As Control
Dim ctl3 As Control
' Build a list of the selections.
Set ctl = Me![Animal]
For Each Itm In ctl.ItemsSelected
If Len(Criteria) = 0 Then
Criteria = Chr(34) & ctl.ItemData(Itm) & Chr(34)
Else
Criteria = Criteria & "," & Chr(34) & ctl.ItemData(Itm) _
& Chr(34)
End If
Next Itm
If Len(Criteria) = 0 Then
Itm = MsgBox("You must select one or more items in the" & _
" list box!", 0, "No Selection Made")
Exit Sub
End If
Set ctl2 = Me![State]
For Each Itm In ctl2.ItemsSelected
If Len(Criteria2) = 0 Then
Criteria2 = Chr(34) & ctl2.ItemData(Itm) & Chr(34)
Else
Criteria2 = Criteria2 & "," & Chr(34) & ctl2.ItemData(Itm) _
& Chr(34)
End If
Next Itm
If Len(Criteria2) = 0 Then
Itm = MsgBox("You must select one or more items in the" & _
" list box!", 0, "No Selection Made")
Exit Sub
End If
' Modify the Query.
Set DB = CurrentDb()
Set Q = DB.QueryDefs("animalquery")
' Modify the Query.
Set DB = CurrentDb()
Set Q = DB.QueryDefs("animalquery")
Q.SQL = "Select * From [table1] Where [table1].[type] In (" & "'Animal'" & _
")" & " and [table1].[animal] in (" & Criteria & _
")" & " and [table1].[state] in (" & Criteria2 & _
")" & ";"
Q.Close
' Run the query.
DoCmd.OpenQuery "animalquery"
End Sub
EDIT - Fix comparison as per comment
You can do this with a simple check of your Criteria vaiables.
You already do the the length check - just use it later on when you build the dynamic SQL.
I added a strSQL variable to make it easier to track what's happening. And adjusted the error message to allow one or other criteria being empty
Private Sub Command6_Click()
Dim Q As QueryDef
Dim DB As Database
Dim Criteria As String
Dim ctl As Control
Dim Itm As Variant
Dim ctl2 As Control
Dim ctl3 As Control
' Use for dynamic SQL statement'
Dim strSQL As String
Set ctl = Me![Animal]
For Each Itm In ctl.ItemsSelected
If Len(Criteria) = 0 Then
Criteria = Chr(34) & ctl.ItemData(Itm) & Chr(34)
Else
Criteria = Criteria & "," & Chr(34) & ctl.ItemData(Itm) & Chr(34)
End If
Next Itm
Set ctl2 = Me![State]
For Each Itm In ctl2.ItemsSelected
If Len(Criteria2) = 0 Then
Criteria2 = Chr(34) & ctl2.ItemData(Itm) & Chr(34)
Else
Criteria2 = Criteria2 & "," & Chr(34) & ctl2.ItemData(Itm) & Chr(34)
End If
Next Itm
If (Len(Criteria) = 0) And (Len(Criteria2) = 0) Then
Itm = MsgBox("You must select one or more items from one of the list boxes!", 0, "No Selection Made")
Exit Sub
End If
' Modify the Query.
Set DB = CurrentDb()
Set Q = DB.QueryDefs("animalquery")
' Modify the Query.
Set DB = CurrentDb()
Set Q = DB.QueryDefs("animalquery")
strSQL = "Select * From [table1] Where [table1].[type] In (" & "'Animal')"
If (Len(Criteria) <> 0) Then ' Append Animal Criteria
strSQL = strSQL & " AND [table1].[animal] IN (" & Criteria & ")"
End If
If (Len(Criteria2) <> 0) Then ' Append State Criteria
strSQL = strSQL & " AND [table1].[state] IN (" & Criteria2 & ")"
End If
Q.SQL = strSQL
Q.Close
' Run the query.
DoCmd.OpenQuery "animalquery"
End Sub

Extract employees between 2 Hire Dates VBA and SQL

I have designed a macro which should extract from a workbook database all employees who were hired between 2 Dates.
Unfortunatley I'm getting a error mesage when I run the query.
Error:
Data Type mismatch in criteria expression.
I don't know how to fix the issue.
My regional settings:
Short date: dd.MM.yyyy
Long date: dddd, d.MMMM.yyyy
First day of week: Monday
Here the code:
Public Sub HIREDATE()
Application.ScreenUpdating = False
Dim cnStr As String
Dim rs As ADODB.Recordset
Dim query As String
Dim fileName As String
Dim pom1 As String
Dim x As String, w, e, blad As String, opis As String
Set w = Application.FileDialog(msoFileDialogFilePicker)
With w
.AllowMultiSelect = False
If .Show = -1 Then
fileName = w.SelectedItems(1)
Else
Exit Sub
End If
End With
cnStr = "Provider=Microsoft.ACE.OLEDB.12.0;" & _
"Data Source=" & fileName & ";" & _
"Extended Properties=Excel 12.0"
On Error GoTo Anuluj
x = InputBox("Wprowadz dwie daty od do oddzielając je przecinkiem -- Przykład 01.01.2015,01.05.2015")
strg = ""
k = Split(x, ",")
e = Application.CountA(k)
For m = LBound(k) To UBound(k)
If e = 1 Then
strg = strg & " [DEU1$].[Last Start Date] = '" & k(m) & "';"
Exit For
ElseIf e = 2 And e Mod 2 = 0 Then
strg = " [DEU1$].[Last Start Date] BETWEEN '" & CDate(k(m)) & "' AND '" & CDate(k(m + 1)) & "';"
Exit For
End If
Next m
On Error GoTo opiszblad
Set rs = New ADODB.Recordset
query = "SELECT [Emplid], [First Name]+ ' ' +[Last Name] From [DEU1$] WHERE" & strg
rs.Open query, cnStr, adOpenUnspecified, adLockUnspecified
Cells.Clear
Dim cell As Range, i As Long
With Range("A3").CurrentRegion
.Select
For i = 0 To rs.Fields.Count - 1
.Cells(1, i + 1).Value = rs.Fields(i).Name
Next i
Range("A4").CopyFromRecordset rs
.Cells.Select
.EntireColumn.AutoFit
End With
rs.Close
Application.ScreenUpdating = True
Exit Sub
Anuluj:
Exit Sub
opiszblad:
e = Err.Number
blad = Err.Source
opis = Err.Description
opisbledu = MsgBox(e & " " & blad & " " & opis, vbInformation, "Błąd")
Exit Sub
End Sub
You need properly formatted string expressions for your dates and to validate the user input:
If e = 1 And IsDate(k(m)) Then
strg = strg & " [DEU1$].[Last Start Date] = #" & Format(DateValue(k(m)), "yyyy\/mm\/dd") & "#;"
Exit For
ElseIf e = 2 And e Mod 2 = 0 And IsDate(k(m + 1)) Then
strg = " [DEU1$].[Last Start Date] BETWEEN #" & Format(DateValue(k(m)), "yyyy\/mm\/dd") & "# AND #" & Format(DateValue(k(m + 1)), "yyyy\/mm\/dd") & "#;"
Exit For
End If

Speeding up a ms access sql query from excel

I have the code below and it seems to be taking a while to open the recordset and run the query attached (62 seconds to be exact). While 1 minute is fine, when I need to do this 13 times, it begins to take a long time to run the code.
I've debugged the code down to just the opening of the recordset taking the longest time.
My question is: Is there a method to run this faster? (i'm connecting to MS Access 2013 from Excel 2013)
Thanks in advance,
Rich
Sub GetUnits2()
'Declaring the necessary variables.
Dim con As Object
Dim rs As Object
Dim AccessFile As String
Dim strTable As String
Dim SQL As String
Dim myValues() As Variant
Dim i As Long
Dim k As Long
Dim j As Integer
Dim SheetName As String
Dim WeekNumber As Long
Dim year As Long
Dim Model1 As String
Dim Model2 As String
Dim xlrow As Integer
Dim xlcol As Integer
SheetName = "Sheet2"
Sheets(SheetName).Select
Model1 = Sheets(SheetName).Cells(3, 2).Value
Model2 = Sheets(SheetName).Cells(4, 2).Value
'Disable screen flickering.
Application.ScreenUpdating = False
'Specify the file path of the accdb file. You can also use the full path of the file like:
AccessFile = "C:\Users\rich.wolff\Desktop\2014POSDatabase\HMKPOSDatabase2014.accdb"
On Error Resume Next
'Create the ADODB connection object.
Set con = CreateObject("ADODB.connection")
'Check if the object was created.
If Err.Number <> 0 Then
MsgBox "Connection was not created!", vbCritical, "Connection error"
Exit Sub
End If
On Error GoTo 0
'Open the connection.
con.Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & AccessFile
'Set Current Week, Year, & Starting Cell
WeekNumber = Sheets(SheetName).Cells(8, 14).Value
year = Sheets(SheetName).Cells(9, 14).Value
xlcol = 14 'Starting Column
xlrow = 11 'Starting Row
'Open Query Loop
For k = 1 To 1
SQL = "SELECT Sum(StoreSalesData.QTY) AS Units"
SQL = SQL & " FROM VSNConversionData INNER JOIN ([Sleepys Store List] INNER JOIN StoreSalesData ON [Sleepys Store List].[Store Code] = StoreSalesData.STR) ON VSNConversionData.VSN = StoreSalesData.VSN"
SQL = SQL & " WHERE (((VSNConversionData.VSNStyle)='" & Model2 & "') AND ((StoreSalesData.WeekNum)=" & WeekNumber & ") AND ((StoreSalesData.Year)=" & year & ") AND ((StoreSalesData.STR) In (SELECT FloorModels2.[Source Org]"
SQL = SQL & " FROM FloorModels2"
SQL = SQL & " WHERE (((FloorModels2.[Source Org]) In (SELECT FloorModels2.[Source Org]"
SQL = SQL & " FROM FloorModels2"
SQL = SQL & " WHERE (((FloorModels2.WeekNumber)=" & WeekNumber & ") AND ((FloorModels2.Year)=" & year & ") AND ((FloorModels2.VSNStyle)='" & Model1 & "')))) AND ((FloorModels2.WeekNumber)=" & WeekNumber & ") AND ((FloorModels2.Year)=" & year & ") AND ((FloorModels2.VSNStyle)='" & Model2 & "')))));"
On Error Resume Next
'Create the ADODB recordset object.
Set rs = CreateObject("ADODB.recordset")
'Check if the object was created.
If Err.Number <> 0 Then
Set rs = Nothing
Set con = Nothing
MsgBox "Connection was not created!", vbCritical, "Connection error"
Exit Sub
End If
On Error GoTo 0
'Set thee cursor location.
rs.CursorLocation = 3 'adUseClient on early binding
rs.CursorType = 1 'adOpenKeyset on early binding
'Open the recordset.
rs.Open SQL, con
'Redim the table that will contain the filtered data.
ReDim myValues(rs.RecordCount)
If Not (rs.EOF And rs.BOF) Then
rs.MoveFirst
Dim dbcol As Integer
dbcol = 0
Worksheets(SheetName).Cells(xlrow, xlcol).ClearContents
Worksheets(SheetName).Cells(xlrow, xlcol).Value = rs(dbcol).Value
Else
rs.Close
con.Close
Set rs = Nothing
Set con = Nothing
Application.ScreenUpdating = True
MsgBox "There are no records in the recordset!", vbCritical, "No Records"
Exit Sub
End If
'Close the recordet
rs.Close
Set rs = Nothing
If WeekNumber = 1 Then
year = year - 1
WeekNumber = 52
Else
year = year
WeekNumber = WeekNumber - 1
End If
' Next Column
xlcol = xlcol - 1
Next
'End Query Loop
con.Close
Set rs = Nothing
Set con = Nothing
Application.ScreenUpdating = True
End Sub
Have I wandered accidentally into a PHP forum?
Declare the ADODB libraries using tools:references - they will run faster, you get intellisense and a listing of all the available properties and options in the Object Browser, and you gain the ability to run the query asynchronously.
That's Early-Binding, an improvement on Late-Binding.
Next, open the Recordset object with dbForwardOnly (slightly faster) and dump it into a VBA array variant with the Recordset.GetRows method: transpose the array in your code, and write it to the range.
I can see that you've made progress on optmising the SQL: try saving it as a parameter query in the database. The ADODB.Command object can open a named query, populate the parameters, and return a recordset - the query itself may or may not run faster, but the lead time to parse the SQL will be significantly faster.
You could try:
Sub M_snb()
c00 = "C:\Users\rich.wolff\Desktop\2014POSDatabase\HMKPOSDatabase2014.accdb"
With Sheets("sheet2")
sn = Array(.Cells(3, 2), .Cells(4, 2), .Cells(8, 14), .Cells(9, 14)) ' model 1, model 2, weeknumber, year
End With
For j = 1 To 13
c01 = "SELECT Sum(StoreSalesData.QTY) AS Units"
c01 = c01 & " FROM VSNConversionData INNER JOIN ([Sleepys Store List] INNER JOIN StoreSalesData ON [Sleepys Store List].[Store Code] = StoreSalesData.STR) ON VSNConversionData.VSN = StoreSalesData.VSN"
c01 = c01 & " WHERE (((VSNConversionData.VSNStyle)='" & sn(1) & "') AND ((StoreSalesData.WeekNum)=" & sn(2) & ") AND ((StoreSalesData.Year)=" & sn(3) & ") AND ((StoreSalesData.STR) In (SELECT FloorModels2.[Source Org]"
c01 = c01 & " FROM FloorModels2"
c01 = c01 & " WHERE (((FloorModels2.[Source Org]) In (SELECT FloorModels2.[Source Org]"
c01 = c01 & " FROM FloorModels2"
c01 = c01 & " WHERE (((FloorModels2.WeekNumber)=" & sn(2) & ") AND ((FloorModels2.Year)=" & sn(3) & ") AND ((FloorModels2.VSNStyle)='" & sn(0) & "')))) AND ((FloorModels2.WeekNumber)=" & sn(2) & ") AND ((FloorModels2.Year)=" & sn(3) & ") AND ((FloorModels2.VSNStyle)='" & sn(1) & "')))));"
With CreateObject("ADODB.recordset")
.Open c01, "Provider=Microsoft.Jet.OLEDB.12.0;Data Source=" & c00
Sheets("sheets2").Cells(11, 14 + j).CopyFromRecordset .DataSource
End With
Next
End Sub