dbf files in Excel with SQL - sql

Every day i need to make a report for salesman, we have 2 dbf files from witch i automatic want to make the report in Excel. Report from 1 dbf file works perfect, but i don't know how to join 2 dbf files in VBA.
I have to following script:
Option Explicit
Sub ReadDBF()
Dim con As Object
Dim rs As Object
Dim DBFFolder As String
Dim FileName As String
Dim FileName1 As String
Dim sql As String
Dim myValues() As String
Dim i As Integer
Dim j As Integer
Application.ScreenUpdating = False
DBFFolder = ThisWorkbook.Path & "\"
FileName = "project1.dbf"
FileName1 = "project2.dbf"
On Error Resume Next
Set con = CreateObject("ADODB.connection")
If Err.Number <> 0 Then
MsgBox "Connection was not created!", vbCritical, "Connection error"
Exit Sub
End If
On Error GoTo 0
con.Open "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & DBFFolder & ";Extended Properties=dBASE IV;"
sql = "SELECT project_id, COUNT(*) AS total, salesman, MAX(date) AS max_date, projectname FROM " & FileName & FileName1 & " where DateValue(datumtijd) = Date() and FileName.project_id = FileName1.project_id " & "group by project_id, salesman"
On Error Resume Next
Set rs = CreateObject("ADODB.recordset")
If Err.Number <> 0 Then
MsgBox "Connection was not created!", vbCritical, "Connection error"
Exit Sub
End If
On Error GoTo 0
rs.CursorLocation = 3
rs.CursorType = 1
rs.Open sql, con
ReDim myValues(rs.RecordCount, 20)
i = 1
If Not (rs.EOF And rs.BOF) Then
'Go to the first record.
rs.MoveFirst
Do Until rs.EOF = True
myValues(i, 1) = rs!project_id
myValues(i, 2) = rs!salesman
myValues(i, 3) = rs!Total
myValues(i, 4) = rs!max_date
myValues(i, 5) = rs!project
rs.MoveNext
i = i + 1
Loop
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
Sheet1.Activate
For i = 1 To UBound(myValues)
For j = 1 To 4
Cells(i + 1, j) = myValues(i, j)
Next j
Next i
rs.Close
con.Close
Set rs = Nothing
Set con = Nothing
Columns("A:D").EntireColumn.AutoFit
Application.ScreenUpdating = True
MsgBox "The values were read from recordset successfully!", vbInformation, "Done"
End Sub

The query doesn't work just by adding the two tables together as the from source. What is it you are trying to actually get? Also, you should never concatenate strings to build a query. They should always be parameterized.
Now, that said, your syntax is simply incorrect. Your variables are referred to as "FileName" and "FileName1", but the underlying TABLES you are querying from are "Project1" and "Project2" respectively. You should learn about aliases to help simplify queries too, and learn proper JOIN syntax.
By listing the tables one after the other with no comma will cause it to fail. Here is a more accurate syntax and formatted for readability. Then I have edited your original query to match the context. You should also always qualify the field names from the respective table so others trying to help know where things are coming from. In the sample below, I have only GUESSED at which table has which columns by using the alias "P1." and "P2." respectively. You will probably need to change them. Also, since "Date" could be interpreted as a reserved word, I have wrapped it in [], but may need to be changed to tick characters (next to number 1) ``
select
P1.Project_ID,
COUNT(*) as Total,
P1.SalesMan,
MAX( P2.[Date] ) as Max_Date,
P1.ProjectName
from
Project1 P1
JOIN Project2 P2
on P1.Project_ID = P2.Project_ID
where
DateValue( P2.datumtijd ) = date()
group by
P1.Project_ID,
P1.SalesMan
The JOIN clause identifies the relation BETWEEN the two tables on respective columns. The WHERE clause is additional criteria you are looking for.
sql = "SELECT project_id, COUNT(*) AS total, salesman, " & _
"MAX(date) AS max_date, projectname " & _
" FROM " & FileName & " P1 " & _
" JOIN " & FileName1 & " P2 ON P1.Project_ID = P2.Project_ID" & _
" where DateValue(datumtijd) = Date() " & _
" group by project_id, salesman"

Related

Microsoft Office Access - Median function - Too few parameters

I am trying to use this code to calculate median from my query which has these criteria:
<[Form]![testForm2]![crit1] And >[Form]![testForm2]![crit2] and <[Form]![testForm2]![Age1] And >[Form]![testForm2]![Age2]
without these criteria function works well and gives for every task median based on "MP", however when I put in there my criteria I receive error:
error - Too few parameters. Expected 4 and then it says 'Object Variable or With block not set'
my input: DMedian("MP";"testForm2";"[TASK]= '" & [TASK] & "'")
*even when the Form is open it end up with the error.
*I probably need to find a different way to filter this query from the form, but I don't know how
Public Function DMedian(FieldName As String, _
TableName As String, _
Optional Criteria As Variant) As Variant
' Created by Roger J. Carlson
' http://www.rogersaccesslibrary.com
' Terms of use: You may use this function in any application, but
' it must include this notice.
'Returns the median of a given field in a given table.
'Returns -1 if no recordset is created
' You use this function much like the built-in Domain functions
' (DLookUp, DMax, and so on). That is, you must provide the
' 1) field name, 2) table name, and 3) a 'Where' Criteria.
' When used in an aggregate query, you MUST add each field
' in the GROUP BY clause into the into the Where Criteria
' of this function.
' See Help for more on Domain Aggregate functions.
On Error GoTo Err_Median
Dim db As DAO.Database
Dim rs As DAO.Recordset
Dim strSQL As String
Dim RowCount As Long
Dim LowMedian As Double, HighMedian As Double
'Open a recordset on the table.
Set db = CurrentDb
strSQL = "SELECT " & FieldName & " FROM " & TableName
If Not IsMissing(Criteria) Then
strSQL = strSQL & " WHERE " & Criteria & " ORDER BY " & FieldName
Else
strSQL = strSQL & " ORDER BY " & FieldName
End If
Set rs = db.OpenRecordset(strSQL, dbOpenDynaset)
'Find the number of rows in the table.
rs.MoveLast
RowCount = rs.RecordCount
rs.MoveFirst
'Determine Even or Odd
If RowCount Mod 2 = 0 Then
'There is an even number of records. Determine the low and high
'values in the middle and average them.
rs.Move Int(RowCount / 2) - 1
LowMedian = rs(FieldName)
rs.Move 1
HighMedian = rs(FieldName)
'Return Median
DMedian = (LowMedian + HighMedian) / 2
Else
'There is an odd number of records. Return the value exactly in
'the middle.
rs.Move Int(RowCount / 2)
'Return Median
DMedian = rs(FieldName)
End If
Exit_Median:
'close recordset
rs.Close
Exit Function
Err_Median:
If Err.number = 3075 Then
DMedian = 0
Resume Exit_Median
ElseIf Err.number = 3021 Then
'EOF or BOF ie no recordset created
DMedian = -1
Resume Exit_Median
Else
MsgBox Err.Description
Resume Exit_Median
End If
End Function
The parameter separation character is comma and you are using a semi-colon
CHANGE:
DMedian("MP";"testForm2";"[TASK]= '" & [TASK] & "'")
TO:
DMedian("MP", "testForm2", "[TASK]= '" & [TASK] & "'")
Solution was to refer the text boxes in SQL declaration, Thank you guys
like this:
HAVING (((Data.[REV]< " & Me.crit1 & ") And (Data.[REV])>" & Me.crit2 & ") AND ((Reg.Age)<" & Me.Age1 & " And (Reg.Age)>" & Me.Age2 & " " & SQLcritComplete & "));"
NOT like this:
"HAVING (((Data.[REV]<[Form]![testForm2]![crit1]) And (Data.[REV])>[testForm2]![crit2]) AND ((Reg.Age)<[Form]![testForm2]![Age1] And (Reg.Age)>[Form]![testForm2]![Age2] & SQLcritComplete & "));"

MS Access - SQL Query for Max Date

I am creating a schedule calendar which has been working great, but I want to adjust the SQL so that it only shows when the next job has to be done. I was thinking the best way to achieve this would be via the MAX() function, however when i run the code Access doesn't seem to like it.
Public Sub LoadArray()
'This sub loads an array with the relevant variables from a query
Dim db As Database
Dim rs As Recordset
Dim rsFiltered As Recordset
Dim strQuery As String
Dim i As Integer
Dim Text23 As Integer
On Error GoTo ErrorHandler
Text23 = Forms.frmPreventativeMenu.Form.CompanyName.Value
strQuery = "SELECT tblWMYReports.Company, tblWMYReports.Machine, MAX(tblWMYReports.NextDate), tblWMYReports.WMY " _
& "FROM tblWMYReports " _
& "WHERE (((tblWMYReports.Company)= " & Text23 & " ));"
Set db = CurrentDb
Set rs = db.OpenRecordset(strQuery)
With rs
If Not rs.BOF And Not rs.EOF Then
'Ensures the recordset contains records
For i = 0 To UBound(MyArray)
'Will loop through the array and use dates to filter down the query
'It firsts checks that the second column has true for its visible property
If MyArray(i, 1) = True Then
.Filter = "[NextDate]=" & MyArray(i, 0)
'To filter you must open a secondary recordset and
'Use that as the basis for a query
'This makes sense as you are building a query on a query
Set rsFiltered = .OpenRecordset
If Not rsFiltered.BOF And Not rsFiltered.EOF Then
'If the recordset is not empty then you are able
'to extract the text from the values provided
Do While Not rsFiltered.EOF = True
MyArray(i, 2) = MyArray(i, 2) & vbNewLine & DLookup("MachineName", "tblMachine", "MachineID=" & rsFiltered!Machine)
MyArray(i, 2) = MyArray(i, 2) & " - " & DLookup("WMY", "tblWMY", "ID=" & rsFiltered!WMY)
rsFiltered.MoveNext
Loop
End If
End If
Next i
End If
.Close
End With
ExitSub:
Set db = Nothing
Set rs = Nothing
Exit Sub
ErrorHandler:
MsgBox "There has been an error. Please reload the form.", , "Error"
Resume ExitSub
End Sub
You are going to aggregate one column with an aggregate function like Sum(), Max(), Count() or similar, then every other column that isn't being aggregated must show up in the SQL's GROUP BY clause:
strQuery = "SELECT tblWMYReports.Company, tblWMYReports.Machine, MAX(tblWMYReports.NextDate), tblWMYReports.WMY " _
& "FROM tblWMYReports " _
& "WHERE (((tblWMYReports.Company)= " & Text23 & " )) " _
& "GROUP BY tblWMYReports.Company, tblWMYReports.Machine, tblWMYReports.WMY;"
I can't guarantee that is going to do what you want it to, since I'm not familiar with your data, code, or application, but it should get you through the error.
You must use a properly formatted string expression for the date value:
.Filter = "[NextDate] = #" & Format(MyArray(i, 0), "yyyy\/mm\/dd") & "#"

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

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.

Access VBA: Concatenate dynamic columns and execute in loop

My question is related to the following two Access tables, named Table_1 and Table_2.
The following codes aims to update [Table_2.CombinedField] column, by concatenating two other columns of the same table. One of the two columns must be [Table_2.BookName], the other column is defined in Table_1.
For example, as you can see in Table_1, novel BookType should use Author to concatenate with BookName, research BookType should use PublishYear etc. That means which column to be used for concatenate in Table_2 is based on Table_1.
Ideally, the target result for following codes should be:
CombinedField
tom - titleA
john - titleB
2010 - titleC
2011 - titleD
company5 - titleE
However, as you see Table_2.CombinedField in above Table_2 screenshot. The code only used the first row of Table_1 (Author) and applies to all rows of Table_2.
Function CombineVariableFields_NoLoop()
On Error Resume Next
Dim ws As Workspace
Dim strSQL As String
Dim fieldname As String
fieldname = DLookup("[SelectCombineField]", "Table_1")
Set ws = DBEngine.Workspaces(0)
Set db = CurrentDb()
On Error GoTo Proc_Err
ws.BeginTrans
strSQL = "UPDATE Table_2 INNER JOIN Table_1 ON Table_2.BookType = Table_1.BookType SET Table_2.CombinedField = [Table_2]![" & fieldname & "] & ' - ' & [Table_2]![BookName]"
db.Execute strSQL, dbFailOnError
ws.CommitTrans
Proc_Exit:
Set ws = Nothing
Exit Function
Proc_Err:
ws.Rollback
MsgBox "Error updating: " & Err.Description
Resume Proc_Exit
End Function
My question
I guess I should use something like loop. However, I don't really know how should I apply loop to the codes in this scenario. (sorry i am new to VBA). Below coding is something by my guess only, appreciate if someone can help to point out what exact codes should be in order to generate my target result for Table_2.CombinedField. Thanks a lot.
The following codes is only my guess
Function CombineVariableFields_Loop()
On Error Resume Next
Dim ws As Workspace
Dim strSQL As String
Dim fieldname As String
Set ws = DBEngine.Workspaces(0)
Set db = CurrentDb()
On Error GoTo Proc_Err
ws.BeginTrans
Set rst = db.OpenRecordset("Select distinct SelectCombineField FROM Table_1", dbOpenDynaset)
With rst
Do While Not .EOF
fieldname = DLookup("[SelectCombineField]", "Table_1", "BookType = " & DLookup("BookType", "Table_2"))
strSQL = "UPDATE Table_2 INNER JOIN Table_1 ON Table_2.BookType = Table_1.BookType SET Table_2.CombinedField = [Table_2]![" & fieldname & "] & ' - ' & [Table_2]![BookName]"
db.Execute strSQL, dbFailOnError
.MoveNext
Loop
End With
ws.CommitTrans
Proc_Exit:
Set ws = Nothing
Exit Function
Proc_Err:
ws.Rollback
MsgBox "Error updating: " & Err.Description
Resume Proc_Exit
End Function
try this:
Set rst = db.OpenRecordset("Select SelectCombineField, BookType FROM Table_1 Where BookType In(Select Distinct BookType From Table_2)", dbOpenDynaset)
With rst
Do While Not .EOF
strSQL = "UPDATE Table_2 SET Table_2.CombinedField = [Table_2].[" & !SelectCombineField & "] & ' - ' & [Table_2].[BookName] Where BookType = '" & !BookType & "'"
db.Execute strSQL, dbFailOnError
.MoveNext
Loop
End With
This may not be the BEST way, but it should work:
"UPDATE Table_2 a INNER JOIN Table_1 b ON a.BookType = b.BookType" _
& "SET Table_2.CombinedField = " _
& "Iif(b.[SelectCombinedField = 'Author', a.[Author], " _
& " Iif(b.[SelectCombinedField = 'PublishYear', a.[PublishYear], " _
& "a.[Publisher])) & ' - ' & a.[BookName]"

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