Filter Recordset, export records to Excel

  • Thread starter Thread starter Arlan
  • Start date Start date
A

Arlan

I have been searching quite awhile and am having a dificult time
accomplishing the following...

I want to loop through a query and filter out records based on another
query, then send the data to an excel template, save it, and
eventually I will be e-mailing each spreadsheet to the user. There
are 136 different users.

qryEmailId contains the UserID (E-mail Address)
qryIncentive contains the Detail Information for each user. Each user
will have between 4 and 5 records (one for each week in our fiscal
month).



Any help would be appreciated.
 
Arlan,

Not sure why you need to "loop through a query and filter out records based
on another query" when you can simply perform this operation in one query
based on both of your base queries. My suggestion is that you create a
variant array based on the single query use the GetRow method of DAO or ADO
and transpose the array then use simple automation to set the range value of
the excel sheet equal to the variant array. Your data will be in Excel in
short order then you can use more automation to execute the "Send To Mail
Recipient As Attachment" option in the Excel Object Model.

The "Programming Excel" topic in the Excel on-line help has more
information.

Dan
 
Thanks for the input, but I will be honest..you lost me...The
following is my code so far..I have been able to manually filter the
base query (qryIncentiveReport) and send this data to an excel
template then save and e-mail, but, what I need to do is via code,
filter for each user, then send that data to the excel template, save
and e-mail, then go onto the next user and filter, send data then save
and e-mail...etc.... Any pointers would be appreciated...Thanks

Function MoveData()



Dim objXL As Object
Dim objBook As Object
Dim objSheet As Object
Dim rsData As Recordset
Dim rsFilter As Recordset
Dim i As Integer
Dim i2 As Integer
Dim straddress As String
Dim appOutlook As New Outlook.Application
Dim objItem As Outlook.MailItem
Dim strExcelPath As String
Dim stDocName As String

stDocName = "qryIncentiveReport1"

'This represents the PK filed to filter for

i2 = 1


Set rsData = CurrentDb.OpenRecordset(stDocName, dbOpenSnapshot)
straddress = rsData!userid


'This is where I am lost....

rsData.Filter = "[ID]=" & i2
Set rsFilter = rsData.OpenRecordset

'I now need to Filter this record set, as I need to
'send each users worksheet to them seperately
'Each users worksheet will have between 3 and 6 records per
'spreadsheet.


If rsFilter.EOF = False Then
Set objXL = CreateObject("Excel.Application")
objXL.Visible = True
Set objBook = objXL.Workbooks.Open("C:\XLS\IncReport.xls")
Set objSheet = objBook.worksheets("template")
objSheet.Activate
i = 9
With rsFilter
.MoveFirst
Do Until .EOF
objSheet.Range("H3") = !userid
objSheet.Range("B5") = !desc
objSheet.Range("B6") = !PeriodYr
objSheet.Range("B7") = !flight
objSheet.Range("A" & i) = !week
objSheet.Range("B" & i) = !Sales
objSheet.Range("C" & i) = !Lines
objSheet.Range("D" & i) = !stops
objSheet.Range("E" & i) = !linesperstop
objSheet.Range("F" & i) = !minsales
objSheet.Range("G" & i) = !targsales
objSheet.Range("H" & i) = !outsales
objSheet.Range("I" & i) = !minlineinc
objSheet.Range("J" & i) = !targlineinc
objSheet.Range("K" & i) = !outlineinc
i = i + 1
.MoveNext
Loop
End With

'ReName the worksheet

objXL.Sheets("template").Name = "Sales Incentive Info"

'Save the workbook with the user ID PD and YR

ActiveWorkbook.SaveAs Filename:="C:\XLS\" & Range("H3") & "" &
Range("B6") & ".xls"

'Set the Path to the newly created workbook for e-mail

strExcelPath = "C:\XLS\" & Range("H3") & "" & Range("B6") & ".xls"

'Create New Mail Message

Set objItem = appOutlook.CreateItem(olMailItem)

With objItem
.To = straddress
.Subject = "Sales Incentive Criteria"
.Attachments.Add strExcelPath
.Display
'.Send
End With


Else
MsgBox "There was a problem"
End If

rsData.Close
Set rsData = Nothing
Set objSheet = Nothing
objBook.Close
Set objBook = Nothing
objXL.Quit
Set objXL = Nothing



End Function
 
Arlan,
Below is some code I pieced together from stuff I had already written, I
attempted to adjust the code to your problem, but you must do the final
tweaking of both the code ProcessUserReports and your queries. Hope this
helps!

Dan

Public Sub ProcessUserReports()
Dim rsUsers As DAO.Recordset
Dim cmdRpt As DAO.QueryDef
Dim rsUserRpt As DAO.Recordset
Dim xlWkb As Excel.WorkBook

' You will need to create a query that will return
' only a unique set of users for instance:
' SELECT DISTINCT User FROM MyTable ORDER BY User
Set rsUser = CurrentDB.OpenRecordset("vw_Users", dbOpenForwardOnly)
Set cmdRpt = CurrentDB.QueryDefs("qryIncentiveReport1")

' Here is your main loop for every users
Do Until (rsUsers.EOF)
' Add a parameter to your query for the user name and use it
' like so:
cmdRpt.Parameters("@User").Value = rsUsers(0).Value
Set rsUserRpt = cmdRpt.OpenRecordset(dbOpenForwardOnly)
Set xlWkb = RecordsetToExcel(rsUserRpt, "TODO: Path to an Excel
template file (*.dot)")
If Not (xlWkb Is Nothing) Then
Call xlWkb.SendMail(rsUser(0).Value, "Subject of Email")
End If
Set xlWkb = Nothing
Loop

' Close Excel
Dim xlApp As Excel.Application
xlApp = Application()
xlApp.Quit
Set xlApp = Nothing
End Sub

Public Function RecordsetToExcel(ByRef rst As DAO.Recordset, ByVal Template
As String) As Excel.WorkBook
Dim xlApp As Excel.Application
Dim xlWkb As Excel.WorkBook
Dim xlWks As Excel.Worksheet

If (rst Is Nothing) Then Exit Function
If (rst.EOF) Then Exit Function

Set xlApp = Application()
xlApp.Visible = False

If Len(Template) = 0 Then
Set xlWkb = xlApp.Workbooks.Add()
Else
Set xlWkb = xlApp.Workbooks.Add(Template)
End If

Set xlWks = xlWkb.ActiveSheet

Call InsertHeader(xlWks, rst)
Call InsertGetRows(xlWks, rst.GetRows(2000))

ExitHandler:
Set xlWks = Nothing
Set xlApp = Nothing
Set RecordsetToExcel = xlWkb
Exit Function
ErrorHandler:
' TODO Log your error
Set xlWkb = Nothing
Resume ExitHandler
End Function

Public Function InsertGetRows(ByRef wks As Excel.Worksheet, _
ByRef source As Variant) As Excel.range

' The array must be transposed first to display it
' properly in Excel

Dim rows As Integer
Dim cols As Integer
Dim irow As Integer
Dim icol As Integer
Dim dest() As Variant
Dim rng As Excel.range

cols = UBound(source, 1)
rows = UBound(source, 2)

ReDim dest(rows, cols)

For irow = 0 To rows
For icol = 0 To cols
dest(irow, icol) = source(icol, irow)
Next icol
Next irow

With wks
Set rng = .range(.Cells(2, 1), .Cells(irow + 1, icol))
rng.Value = dest
Set InsertGetRows = rng
End With

End Function

Public Sub InsertHeader(ByRef xlWks As Excel.Worksheet, ByRef rst As
DAO.Recordset)
Dim icol As Integer
' Insert the header, remember the result set is zero base
' where the spreadsheet is one based.

For icol = 0 To rst.Fields.Count - 1
xlWks.Cells(1, icol + 1).Value = rst.Fields(icol).Name
Next
End Sub

Public Property Get Application() As Excel.Application
Dim exl As Excel.Application

On Error GoTo ErrorHandler
Set exl = GetObject(, "Excel.Application")

ExitHandler:
Set Application = exl
Exit Property
ErrorHandler:
If exl Is Nothing Then
Set exl = New Excel.Application
End If
Resume ExitHandler
End Property

Arlan said:
Thanks for the input, but I will be honest..you lost me...The
following is my code so far..I have been able to manually filter the
base query (qryIncentiveReport) and send this data to an excel
template then save and e-mail, but, what I need to do is via code,
filter for each user, then send that data to the excel template, save
and e-mail, then go onto the next user and filter, send data then save
and e-mail...etc.... Any pointers would be appreciated...Thanks

Function MoveData()



Dim objXL As Object
Dim objBook As Object
Dim objSheet As Object
Dim rsData As Recordset
Dim rsFilter As Recordset
Dim i As Integer
Dim i2 As Integer
Dim straddress As String
Dim appOutlook As New Outlook.Application
Dim objItem As Outlook.MailItem
Dim strExcelPath As String
Dim stDocName As String

stDocName = "qryIncentiveReport1"

'This represents the PK filed to filter for

i2 = 1


Set rsData = CurrentDb.OpenRecordset(stDocName, dbOpenSnapshot)
straddress = rsData!userid


'This is where I am lost....

rsData.Filter = "[ID]=" & i2
Set rsFilter = rsData.OpenRecordset

'I now need to Filter this record set, as I need to
'send each users worksheet to them seperately
'Each users worksheet will have between 3 and 6 records per
'spreadsheet.


If rsFilter.EOF = False Then
Set objXL = CreateObject("Excel.Application")
objXL.Visible = True
Set objBook = objXL.Workbooks.Open("C:\XLS\IncReport.xls")
Set objSheet = objBook.worksheets("template")
objSheet.Activate
i = 9
With rsFilter
.MoveFirst
Do Until .EOF
objSheet.Range("H3") = !userid
objSheet.Range("B5") = !desc
objSheet.Range("B6") = !PeriodYr
objSheet.Range("B7") = !flight
objSheet.Range("A" & i) = !week
objSheet.Range("B" & i) = !Sales
objSheet.Range("C" & i) = !Lines
objSheet.Range("D" & i) = !stops
objSheet.Range("E" & i) = !linesperstop
objSheet.Range("F" & i) = !minsales
objSheet.Range("G" & i) = !targsales
objSheet.Range("H" & i) = !outsales
objSheet.Range("I" & i) = !minlineinc
objSheet.Range("J" & i) = !targlineinc
objSheet.Range("K" & i) = !outlineinc
i = i + 1
.MoveNext
Loop
End With

'ReName the worksheet

objXL.Sheets("template").Name = "Sales Incentive Info"

'Save the workbook with the user ID PD and YR

ActiveWorkbook.SaveAs Filename:="C:\XLS\" & Range("H3") & "" &
Range("B6") & ".xls"

'Set the Path to the newly created workbook for e-mail

strExcelPath = "C:\XLS\" & Range("H3") & "" & Range("B6") & ".xls"

'Create New Mail Message

Set objItem = appOutlook.CreateItem(olMailItem)

With objItem
.To = straddress
.Subject = "Sales Incentive Criteria"
.Attachments.Add strExcelPath
.Display
'.Send
End With


Else
MsgBox "There was a problem"
End If

rsData.Close
Set rsData = Nothing
Set objSheet = Nothing
objBook.Close
Set objBook = Nothing
objXL.Quit
Set objXL = Nothing



End Function


"solex" <[email protected]> wrote in message
Arlan,

Not sure why you need to "loop through a query and filter out records based
on another query" when you can simply perform this operation in one query
based on both of your base queries. My suggestion is that you create a
variant array based on the single query use the GetRow method of DAO or ADO
and transpose the array then use simple automation to set the range value of
the excel sheet equal to the variant array. Your data will be in Excel in
short order then you can use more automation to execute the "Send To Mail
Recipient As Attachment" option in the Excel Object Model.

The "Programming Excel" topic in the Excel on-line help has more
information.

Dan
Click to expand...
Click to expand...
 
Back
Top